home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / OTHER_LA / YERK__ / NUC / YERK.TXT < prev   
Text File  |  1990-12-31  |  78KB  |  3,460 lines
  1. ; courier 9pt -9 spacing tabs: .875 1.5 3.625
  2. ; modified GETEVENT to need nothing off of stack
  3. ; added lineto
  4. ; need to change modification in vers RSRC
  5. ;    Load equates for Toolbox, Quickdraw
  6.     LIST OFF
  7.     INCLUDE    "library.asm"
  8.     INCLUDE    "equates.asm"
  9.     INCLUDE    "yerk.macro"
  10. newhandc    EQU    $a322
  11. newPtrc    EQU    $a31e
  12. waitNextEvt    EQU    $a860
  13.     GLOBAL    $200,$200
  14.     ENDG
  15.     TFILE "YERK.BIN"
  16.     RFILE "YERK",APPL,YERK,$2100    ; has bundle,init
  17.     SEG    1,52
  18. *
  19. origin    bra    ftInit    ; branch around initialization da
  20. one    EQU    origin
  21. segStart    EQU    origin-4
  22. lkorigin    EQU    origin    ; null link for first entry
  23. ;        begin USER initialization data
  24. ;
  25. Rsize    EQU    400    ; Maximum depth of ret+mstack
  26. Rbytes    EQU    -Rsize*4    ; Number of bytes for ret+mstack
  27. MSbytes    EQU    1200    ; 300 cells on methods stack
  28. HeapSiz    EQU    82000    ; min size of heap given to system
  29. maxDict    EQU    $3ffff    ; max size of user dict to get
  30. sysVects    EQU    17    ; how many system vectors + 1 (for len)
  31. sysVecSz    EQU    sysVects*4    ; total len of system vector table
  32. ; 'SAVE' HEADER EQUATES.
  33. udp    EQU    0    ; User dictionary pointer
  34. ufence    EQU    4    ; User fence pointer
  35. uvocl    EQU    8    ; User vocabulary pointer
  36. ulatest    EQU    12    ; Latest NFA.
  37. headlen    EQU    16    ; Length of header
  38. ; Finder Handle Offsets
  39. opflag    EQU    0    ; Open/Print flag
  40. numfiles    EQU    2    ; Number of files
  41. volrnum    EQU    0    ; Volume reference number
  42. ftype    EQU    2    ; File type
  43. fvernum    EQU    6    ; File's version number
  44. fname    EQU    8    ; File name ( <count> <name> )
  45. f.handle    EQU    16    ; Offset to finder handle
  46. YerkID    ASC    "3300"    ; Release, version, revision, 0
  47.     ADJST
  48. initLast    DATA    Lastdef-origin    ; origin + 12: last definition addr
  49. initFenc    DATA    Lastdef-origin    ; fence
  50. initS0    DATA    0    ; offset from A3 for initial A7 (SP)
  51. initR0    DATA    0    ; offset from A3 for initial A6
  52. initmp    DATA    0    ; offset from A3 for initial D5
  53. initDP    DATA    0    ; DP - starts past sys vector table
  54. initVocl    DATA    0    ; VOC-LINK - last COLD init
  55. Userror    DATA    0    ; Error during load
  56. memsize    DATA    0    ; Size of memory acquired
  57. memPtr    DATA    0    ; abs ptr to the user dict heap
  58. userdp    DATA    0    ; Pointer to the user dict heap
  59. stksize    DATA    $ffffe078    ; 8072 stack size
  60. ;
  61. ;    End USER initialization data
  62. ;
  63. ; Save environment passed in from Pascal main - address of buffer
  64. ;
  65. ftInit    lea    memsize(PC),a0    ; see if this is a reboot
  66.     tst.l    (a0)    ; if mem already acquired,
  67.     bne    coldvec    ; skip initialization code
  68.     movem.l    A3/A4/A6/D3-D7,-(sp)    ; save Pascal regs
  69. ;
  70. ; set up a6 to point to beginning of method stack, a7 set to
  71. ; beginning of data stack
  72. ;
  73.     link    a6,#rbytes    ; a6=R0,a7=S0 return stack
  74.     pea    -4(a5)
  75.     _InitGraf    ; initGraf(@thePort)
  76.     lea    origin(PC),a3    ; a3 -> code base at load
  77.     lea    stksize(PC),a0
  78.     move.l    (a0),d1
  79.     lea    0(a7,d1.l),a0    ; leave stack space
  80.     _setApplLimit
  81.     _maxMem        ; force purge of the heap
  82.     jsr    loaduser(PC)    ; load application dictionary if any
  83.     moveq    #(initS0-origin),d7    ; put offset into D7
  84.     move.l    SP,d0    ; store SP in d0
  85.     sub.l    a3,d0    ; reference to yerk base
  86.     move.l    d0,0(a3,d7.l)    ; inits0 now has offset to data stk
  87.     move.l    a6,d0    ; A6 points to methods stack
  88.     sub.l    a3,d0    ; reference to yerk base
  89.     lea    initmp(PC),a2    ; Init methods stack for cold load
  90.     move.l    d0,(a2)    ; initmp now has mstack offset
  91.     subi.l    #msbytes,d0    ; Leave 300 cells for M stack
  92.     move.l    d0,4(a3,d7.l)    ; initr0 now has offset to ret stk
  93. *
  94. COLDVEC    bra.s    ECLD    ; jump to cold start
  95. WARMVEC    bra.s    EWRM    ; jump to warm start
  96. ; =======Inner Interpreter ===========
  97. donext    move.l    (a4)+,d6    ; get next threaded instruction (32bit)
  98.     move.l    0(a3,d6.l),d7    ; get code address
  99.     jmp    0(a3,d7.l)    ; jump to code addr relative to a3
  100.     nop
  101. ECLD    lea    cld1(PC),a4    ; A4 is IP in inner interpreter
  102.     bra.s    EWRM1
  103. EWRM    lea    warm1(PC),a4    ; A4 is IP in inner interpreter
  104. EWRM1    lea    origin(PC),a3
  105.     moveq    #(initS0-origin),d7    ; get address of initS0 in D7
  106.     movea.l    0(a3,d7.l),SP    ; pickup s0 address in SP
  107.     adda.l    a3,SP
  108.     movea.l    4(a3,d7.l),a6    ; pickup r0 address in a6
  109.     adda.l    a3,a6
  110.     move.l    initmp(PC),d5    ; Pick methods stack pointer
  111.     add.l    a3,d5
  112.     jmp    donext(PC)
  113. warm1    cfas    cls,abort,semis
  114. ; Loaduser routine loads the user dictionary if there is one to be loaded.
  115. ; First get some Heap to read the user dictionary into. We want
  116. ; get as much heap as there is available, minus some for the system.
  117. loaduser
  118.     lea    0(a7,d1.l),a0        
  119.     lea    lastdef(PC),a1    ; Top of nucleus
  120.     suba.l    a1,a0    ; Max. mem available
  121.     move.l    a0,d0
  122. heapWord
  123.     subi.l    #heapsiz,d0    ; Leave n k for other things.
  124.     cmpi.l    #maxDict,d0    ; leave more heap on big MACS
  125.     blt    allHeap
  126.     move.l    #maxDict,d0    ; limit dict size
  127. allheap
  128.     lea    memsize(PC),a2    ; small machine
  129.     move.l    d0,(a2)    ; Save memory size.
  130.     lea    segStart(PC),a0    ; segment start
  131.     _RecoverHandle    ; handle to CODE 1 segment
  132.     addi.l    #(nextdef-origin+76),d0    ; add in length of nucleus
  133.     _SetHandleSize    ; grow CODE 1 to accom user dict
  134.     lea    nextdef+2(PC),a0    ; clear newly acquired space
  135.     move.l    (a2),d0
  136.     asr.l    #2,d0    ; number of long words to clear
  137. clm    clr.l    (a0)+
  138.     dbra    d0,clm
  139.     lea    nextdef+2(PC),a0
  140.     lea    memptr(PC),a2
  141.     move.l    a0,(a2)    ; Save the memory pointer
  142. ; set up DP
  143.     suba.l    a3,a0    ; a0 has relative base of user dict
  144.     lea    initdp(PC),a2
  145.     move.l    a0,(a2)    ; Set default dp
  146.     andi.l    #$FFFFFF,(a2)    ; mask out hi byte
  147.     add.l    #sysvecSz,(a2)    ; bump dp past system vector table
  148. *
  149.     lea    userdp(PC),a2    ; Save pointer to dict. begin
  150.     move.l    a0,(a2)
  151.     andi.l    #$FFFFFF,(a2)
  152.     jsr    loadcom(PC)
  153.     rts
  154. ;
  155. ; Get the finder handle and see if there is file to be opened
  156. ;
  157. loadcom    movea.l    f.handle(a5),a0    ; Get finder handle
  158.     movea.l    (a0),a0    ; Dereference it
  159.     tst.w    (a0)    ; Check if open or print
  160.     beq    load010    ; ok to open
  161.     movea.l    #2,a0    ; error. we don't print
  162.     bra    loaderror
  163. ; The file is to be opened. See if there are any files to open.
  164. load010
  165.     tst.w    numfiles(a0)    ; any files to open?
  166.     bne    load020    ; at least one
  167.     movea.l    #1,a0    ; none. just the nucleus
  168.     bra    loaderror
  169. ; We have at least one file to be opened. Even if there are more than
  170. ; one at this point we are only going to open the first file picked.
  171. load020
  172.     adda.l    #4,a0    ; a0 points past the header
  173.     move.l    ftype(a0),a1    ; get filetype of the file
  174.     cmpa.l    #$434f4d20,a1    ; is it 'COM ' ?
  175.     bne    loaderror
  176.     lea    usefcb(PC),a1    ; load pointer to usefcb
  177.     lea    fname(a0),a2    ; load pointer to filename
  178.     move.l    a2,IoFileName(a1)    ; set file pointer in the fcb
  179.     lea    (a0),a2    ; load pointer to VRefNum
  180.     move.w    (a2),IoVRefNum(a1)    ; set VRefNum in the fcb
  181.     move.b    #1,IoPermssn(a1)    ; set i/o permission to readonly
  182.     move.l    a1,a0    ; Fcb in a0 for call
  183.     _open        ; Open the file
  184.     tst.w    IoResult(a0)    ; Check for errors
  185.     beq    load030    ; continue if ok
  186.     movea.l    IoResult(a0),a0    ; error code
  187.     bra    loaderror    ; Off to process errors
  188. ; Now get the file size so that we know how much to read in.
  189. load030    
  190.     movea.l    a1,a0    ; get the fcb back in a0
  191.     _getfileinfo    ; get info on the file
  192.     tst.w    IoResult(a0)    ; Check for errors
  193.     beq    load040    ; continue if ok
  194.     movea.l    IoResult(a0),a0    ; error code
  195.     bra    loaderror    ; Off to process errors
  196. load040
  197.     lea    nextdef+2(PC),a4    ; Get buffer addr
  198.     move.l    IoflLgLen(a0),d1    ; Get the logical length of file
  199.     movea.l    a1,a0    ; Fcb again
  200.     move.l    a4,iobuffer(a0)    ; Set buffer pointer for data in
  201.     move.l    #headlen,IoReqCount(a0)    ; Number of bytes to read
  202.     clr.l    IoPosMode(a0)    ; Read from beginning of file
  203.     clr.l    IoPosOffset(a0)    ; offset by 0
  204.     _read
  205.     tst.w    IoResult(a0)    ; Check for errors
  206.     beq    load060    ; continue if ok
  207.     movea.l    IoResult(a0),a0    ; error code
  208.     bra.s    loaderror    ; Off to process errors
  209. ; Initialize COLD load variables so that the user dictionary is included
  210. ; when the FORTH system is brought up.
  211. load060
  212.     lea    initdp(PC),a2
  213.     move.l    (a4),(a2)    ; Set dictionary pointer
  214.     lea    initfenc(PC),a2
  215.     move.l    ufence(a4),(a2)    ; Set fence pointer
  216.     lea    initvocl(PC),a2
  217.     move.l    uvocl(a4),(a2)    ; Set vocabulary link
  218.     lea    initLast(PC),a2
  219.     move.l    ulatest(a4),(a2)    ; Set latest NFA
  220. ; Now we can read the dictionary into the memory.
  221.     subi.l    #headlen,d1    ; Size of dictionary to read
  222.     move.l    d1,IoReqCount(a0)
  223.     clr.l    IoPosMode(a0)    ; Position to beginning of file
  224.     move.l    #headlen,IoPosOffset(a0)    ; Offset by headlen
  225.     _read        ; read the dictionary
  226.     tst.w    IoResult(a0)    ; Check for errors
  227.     beq    load070    ; continue if ok
  228.     movea.l    IoResult(a0),a0    ; error code
  229. loaderror
  230.     lea    userror(PC),a2
  231.     move.l    a0,(a2)    ; Save error code for cold
  232.     bra.s    load080
  233. load070
  234.     movea.l    a1,a0    ; fcb again
  235.     _close        ; Close the file
  236. load080
  237.     rts
  238. ; --------------------------------------
  239. ; area for calls to Toolbox, etc.
  240. ftwork    DEFS    20
  241. ftwork1    DC.L    0
  242. dsmsg    STR    "Parameter Stack:"
  243. rsmsg    STR    "Return Stack:   "
  244. msmsg    STR    "Methods Stack:  "
  245. emptymsg    STR    "  <empty>"
  246. pausemsg    STR    "Paused - <Space Bar> to continue>>>"
  247. bytesleft    STR    "Bytes Available: "
  248. hello    STR    "Macintosh YERK Version 3.3 "
  249.     ADJST
  250. tibbuf    DEFS    128    ; terminal input buffer
  251.     DATA    /0
  252.     DEFS    20    ; for numeric output
  253. padbuf    DEFS    256    ; text output buffer
  254. aregn    DATA    0    ; region handle for miscellany
  255.     ADJST
  256. ; Begin nucleus definitions
  257.     ADJST
  258. cld1    cfas    xcold,quit    ; do COLD word and enter Forth
  259. ; ====================================================
  260. ; Following are data areas that will be patched to look like objects
  261. ; after the Class/Object support code is in. Cfas will be patched to
  262. ; Class pointers.
  263. ; ====================================================
  264.     dcode    FWIND,x,origin,fwind ; link should be 0
  265. wRecord    
  266.     DEFS    windowsize    ; window record
  267.     DC.W    40,2,290,494    ; content rect boundaries
  268.     DC.W    8,8,340,510    ; grow rect boundaries
  269.     DC.W    -10000,-10000,10000,10000    ; drag rect boundaries
  270.     DC.W    1,1,1    ; growflg,dragflg, alive
  271.     DATA    nulw-origin    ; idle vector
  272.     DATA    cls-origin    ; deact vector
  273.     DATA    nulw-origin    ; content vector
  274.     DATA    nulw-origin    ; draw vector
  275.     DATA    nulw-origin    ; enact vector
  276.     DATA    nulw-origin    ; close vector
  277.     DC.W    0    ; resid
  278.     dcode    FEVENT,x,fwind,fevent
  279. eventRec    DC.W    0    ; event record for GetNextEvent
  280. eventMsg    DC.L    0,0,0
  281. eventMod    DC.W    0
  282. eventmsk    DC.W    0
  283. eventSlp    DC.L    0
  284. mousRgn    DC.L    0
  285.     DC.W    4,16    ; header for event indexed area
  286.     DEFS    64
  287.     dcode    FFCB,x,fevent,ffcb
  288. ; ------------- Default FCB ------------
  289. useFCB    DEFS    144    ; Parm block for USING file
  290. useFname    DEFS    64    ; holds USING volume/file name string
  291.     DATA    0,0,0,0    ; FCB reclen,ioRefnum,VolRefnum, bufptr
  292. ; -----------------------------------------
  293. fcbl    EQU    *-useFCB    ; length of FCB
  294.     dcode    FPRECT,x,ffcb,fprect
  295. pRect    DC.W    0,0,294,470    ; Forth window rectangle
  296. ; =============================================================
  297.     dcode    ADOC,x,fprect,adoc
  298.     jsr    loadcom(PC)    ; load user dict according to fInfo
  299.     jmp    donext(PC)
  300. ; system values
  301.     dval    S0,adoc,s0,0
  302.     dval    R0,S0,r0,0
  303.     dval    TIB,r0,tib,tibbuf-origin
  304.     dval    WARNING,tib,warn,1
  305.     dval    FENCE,warn,fence,0
  306.     dval    DP,fence,dp,0
  307.     dval    VOC-LINK,dp,vocl,0
  308.     dval    IN,vocl,in,0
  309.     dval    OUT,in,out,0
  310.     dval    CONTEXT,out,contxt,0
  311.     dval    CURRENT,contxt,currnt,0
  312.     dval    STATE,currnt,state,0
  313.     dval    CSTATE,state,cstate,0
  314.     dval    BASE,cstate,base,10
  315.     dval    DPL,base,dpl,0
  316.     dval    CSP,dpl,csp,0
  317.     dval    HLD,csp,hld,0
  318.     dval    WNEAVAIL,hld,wneavail,0    ; true if waitNextEvent in ROM
  319.     dval    HWPAVAIL,wneavail,hwpavail,0    ; true if flush cache
  320.     dvect    VMODEL,hwpavail,vmodel,nulw    ; model for other vectors
  321.     dcon    NEXT,vmodel,next,donext
  322.     dcon    MPATCH,next,mpatch,heapword+2    ; addr of heap size patch
  323.     dcon    BEGIN-DP,mpatch,bdp,userdp    ; use @
  324.     dcon    LOAD-ERROR,bdp,lerror,Userror    ; use @
  325.     dval    M0,lerror,m0,0
  326.     dcon    WSIZE,m0,winsiz,windowsize+origin
  327.     dcon    CTLSIZE,winsiz,ctlsiz,contrlsize+origin
  328.     dcon    USE-FCB,ctlsiz,ufcb,useFCB    ; pushes addr of useFCB
  329.     dcon    MSIZE,ufcb,msiz,memsize    ; use @
  330.     dcon    BL,msiz,bl,$20+origin
  331.     dcon    TRUE,bl,true,1+origin
  332.     dcon    FALSE,true,false,0+origin
  333.     dsvect    KEYVEC,false,keyvec,4,key_    ; system vectors for I/O
  334.     dsvect    EMITVEC,keyvec,emitvec,8,emit_    ; console emit
  335.     dsvect    PEMITVEC,emitvec,pemitv,12,drop    ; printer emit
  336.     dsvect    TYPEVEC,pemitv,typevec,16,type_    ; console type
  337.     dsvect    PTYPEVEC,typevec,ptypev,20,drop2
  338.     dsvect    EXPVEC,ptypev,expvec,24,expect    ; expect
  339.     dsvect    ECHOVEC,expvec,echovec,28,emit_    ; echo for keys
  340.     dsvect    ABORTVEC,echovec,abvec,32,nulw    ; installable abo
  341.     dsvect    QUITVEC,abvec,quvec,36,nulw    ; installable startup vector
  342.     dsvect    UFIND,quvec,ufind,40,false    ; vector for user find
  343.     dsvect    OBJINIT,ufind,objini,44,nulw    ; init nucleus objs
  344.     dsvect    PCRVEC,objini,pcrvec,48,nulw    ; printer CR
  345.     dsvect    BLDVEC,pcrvec,bldvec,52,nulw    ; object builder
  346.     dsvect    CREATE,bldvec,kreate,56,creat_    ; create vector
  347.     dsvect    INTERPRET,kreate,interp,60,intrp_
  348.     dsvect    CRVEC,interp,crvec,64,cr_
  349.     dval    DISK-ERROR,crvec,dkerr,0
  350.     dval    CURS,dkerr,curs_,1    ; cursor on/off flag
  351. crsflag    EQU    *-4
  352.     dval    UCFLAG,curs_,ucflag,1    ; map to upper case
  353. ; ==============================================
  354.     dcode    BYE,x,ucflag,bye_
  355.     _exitToShell
  356. *
  357.     dcode    (CODEZONE),x,bye_,instal
  358.     lea    segStart(PC),a1    ; set CODE 1 resource size
  359.     movea.l    a1,a0
  360.     _recoverHandle    ; get a handle to appl
  361.     move.l    (a7)+,d0    ; get ending rel addr
  362.     addq.l    #1,d0
  363.     andi.l    #-2,d0    ; ensure even
  364.     addi.l    #$4c,d0    ; add header length
  365.     _SetHandleSize    ; increase the size
  366.     jmp    donext(PC)
  367. *
  368.     dcode    FINFO,x,instal,finfo    ; point to finder handle
  369.     movea.l    f.handle(a5),a0
  370.     movea.l    (a0),a0    ; dereference
  371.     suba.l    a3,a0    ; make relative
  372.     move.l    a0,-(SP)    ; push dereferenced ptr
  373.     jmp    donext(PC)
  374. *
  375.     dcode    .CUR,x,finfo,dotcur    ; draw a cursor
  376. pcurs1    jsr    pcurs(PC)
  377.     jmp    donext(PC)
  378. *
  379. pcurs    lea    crsflag(PC),a0    ; ( -- )
  380.     tst.l    (a0)    ; is cursor on or off?
  381.     beq    nocurs
  382.     pea    ftwork(PC)
  383.     _GetPenState    ; get the current pen state
  384.     move.w    #10,-(SP)    ; set xor mode
  385.     _PenMode
  386.     move.w    #7,-(SP)
  387.     clr.w    -(SP)
  388.     _Line
  389.     pea    ftwork(PC)
  390.     _SetPenState
  391. nocurs    rts
  392. *
  393.     dcode    (EMIT),x,dotcur,emit_
  394.     jsr    pcurs(PC)
  395.     addq.l    #2,SP    ; long -> integer
  396.     _DrawChar    ; expects Pascal CHAR on stack
  397.     jsr    pcurs(PC)
  398.     jmp    donext(PC)
  399. *
  400.     dcode    (TYPE),x,emit_,type_
  401.     move.l    a3,d0
  402.     add.l    d0,4(SP)    ; make address absolute
  403.     clr.l    d0
  404.     move.w    2(SP),d0
  405.     swap    d0
  406.     move.l    d0,(SP)    ; zero start byte offset
  407.     _DrawText
  408.     jsr    pcurs(PC)
  409.     jmp    donext(PC)
  410. *
  411.     dcode    NULW,x,type_,nulw    ; empty word for stubbing vectors
  412.     jmp    donext(PC)
  413. *
  414.     dcode    WORD0,x,nulw,word0    ; push a word of 0 for function setup
  415.     clr.w    -(SP)
  416.     jmp    donext(PC)
  417. *
  418.     dcode    PACK,x,word0,pack_    ; packs 2 longs into one
  419.     popd0        ; get y
  420.     addq.l    #2,SP
  421.     move.w    d0,-(SP)
  422.     jmp    donext(PC)
  423. *
  424.     dcode    UNPACK,x,pack_,unpack
  425.     move.l    (sp),d0
  426.     move.w    d0,d1
  427.     ext.l    d1
  428.     move.l    d1,(SP)
  429.     asr.l    #8,d0
  430.     asr.l    #8,d0
  431.     move.l    d0,-(SP)
  432.     jmp    donext(PC)
  433. *
  434.     dcode    I->L,x,unpack,itol    ; extend 16 bit stack cell to 32
  435.     move.w    (sp)+,d0
  436.     ext.l    d0
  437.     move.l    d0,-(SP)
  438.     jmp    donext(PC)
  439. *
  440.     dcode    MAKEINT,x,itol,makint
  441.     addq.l    #2,SP    ; drop high-level word on stack
  442.     jmp    donext(PC)
  443. *
  444.     dcode    NEWPTR,x,makint,xnewpt
  445.     popd0        ; get size for new block in d0
  446.     _NewPtrC        ; call the memory manager for a new block
  447.     sub.l    a3,a0    ; make ptr relative
  448.     move.l    a0,-(SP)    ; push ptr to nonrelocatable block
  449.     jmp    donext(PC)
  450. *
  451.     dcode    NEWHANDLE,x,xnewpt,xnewha
  452.     popd0
  453.     _newHandC    ; special vers of _NewHandle
  454.     move.l    a0,-(SP)    ; push handle to relocatable block
  455.     jmp    donext(PC)
  456. *
  457.     dcode    LOCK,x,xnewha,xlock
  458.     movea.l    (SP),a0    ; get handle in a0
  459.     _hLock        ; mark the block locked
  460.     movea.l    (SP),a0
  461.     movea.l    (a0),a1    ; dereference the handle
  462.     suba.l    a3,a1    ; make it a Forth address based on a3
  463.     move.l    a1,(SP)    ; leave Forth address on stack
  464.     jmp    donext(PC)
  465. *
  466.     dcode    KILLPTR,x,xlock,killpt    ; (relPtr -- )
  467.     movea.l    (SP)+,a0    ; get rel ptr in a0
  468.     add.l    a3,a0    ; make it absolute
  469.     _disposPtr    ; release it
  470.     jmp    donext(PC)
  471. *
  472.     dcode    KILLHANDLE,x,killpt,killha
  473.     movea.l    (SP)+,a0    ; get handle
  474.     _disposHandle
  475.     jmp    donext(PC)
  476. *    
  477.     dcode    GROWPTR,x,killha,groptr    ; ( bytes relptr --)
  478.     movea.l    (SP)+,a0    ; get rel ptr in a0
  479.     adda.l    a3,a0    ; make it absolute
  480.     move.l    a0,d4
  481.     _getPtrSize
  482.     add.l    (sp)+,d0    ; get new handle size
  483.     movea.l    d4,a0
  484.     _SetPtrSize    ; grow the block
  485.     jmp    donext(PC)
  486. *
  487.     dcode    FREE,x,groPtr,free_    ; ( -- maxAvail )
  488.     _freeMem        ; what is max mem avail on heap?
  489.     pushd0        ; includes purging
  490.     jmp    donext(PC)
  491. *
  492.     dcode    FREEBLK,x,free_,freblk
  493.     _maxmem        ; what is max mem avail on heap?
  494.     pushd0        ; includes purging
  495.     jmp    donext(PC)
  496. *
  497.     dcode    >PTR,x,freblk,fetptr    ; ( handle    --- relptr )
  498.     movea.l    (SP),a0
  499.     move.l    (a0),d0    ; dereference a handle
  500.     andi.l    #$ffffff,d0    ; mask out hi byte
  501.     sub.l    a3,d0
  502.     move.l    d0,(SP)    ; return its pointer
  503.     jmp    donext(PC)
  504. *
  505.     dcode    GET-EVENT,x,fetptr,getevt
  506.     move.l    (SP)+,d7    ; get event mask into d7
  507.     swap    d7
  508. ev1    move.l    d7,-(SP)    ; make room for function return
  509.     lea    eventRec(PC),a0    ; ptr to event rec storage
  510.     move.l    a0,-(sp)
  511.     tst.b    wneavail9+3-origin(a3)    ; is waitnextevent here?
  512.     beq.s    usegne0
  513.     move.l    18(a0),-(sp)    ; get sleep value
  514.     move.l    22(a0),-(sp)    ; get mouse rgn
  515.     _waitNextEvt
  516.     bra.s    endevt0
  517. usegne0    _SystemTask    ; WNE not in ROM
  518.     _GetNextEvent
  519. endevt0    tst.w    (SP)+    ; should we handle this event?
  520.     beq    ev1    ; no - get another one
  521.     lea    eventRec(PC),a0
  522.     clr.l    d0
  523.     move.w    (a0),d0    ; pick up event type
  524.     beq.s    ev1    ; loop if null event
  525.     pushd0        ; push event type for caller
  526.     jmp    donext(PC)
  527. *
  528.     dcode    ?EVENT,x,getevt,qevt
  529.     move.l    (SP)+,d7    ; get event mask into d0
  530.     swap    d7
  531.     move.l    d7,-(SP)    ; make room for function return
  532.     pea    eventRec(PC)    ; pointer to event rec storage
  533.     _EventAvail    ; call Toolbox
  534.     tst.w    (SP)+    ; should we handle this event?
  535.     beq    event1    ; no - return false
  536.     lea    eventRec(PC),a0
  537.     clr.l    d0
  538.     move.w    (a0),d0    ; pick up event type
  539.     beq    event1    ; loop if null event
  540. event2    move.l    #1,-(SP)    ; push true - event available
  541.     bra.s    event3
  542. event1    clr.l    -(SP)    ; push false - no event available
  543. event3    jmp    donext(PC)
  544. *
  545.     dcode    GETEVENT,x,qevt,gevt    ; (  --- b )
  546.     clr.w    -(sp)    ; make room for function return
  547.     lea    eventRec(PC),a0
  548.     move.w    eventMsk-eventRec(a0),-(sp)    ; get event mask
  549.     move.l    a0,-(sp)
  550.     tst.b    wneavail9+3-origin(a3)    ; is waitnextevent here?
  551.     beq.s    usegne
  552.     move.l    18(a0),-(sp)    ; get sleep value
  553.     move.l    22(a0),-(sp)    ; get mouse rgn
  554.     _waitNextEvt
  555.     bra.s    endevt
  556. usegne    _SystemTask    ; WNE not in ROM
  557.     _GetNextEvent
  558. endevt    clr.w    -(SP)    ; make an integer a long
  559.     jmp    donext(PC)
  560. *
  561.     dcode    @EVENT-MSG,x,gevt,ftemsg
  562.     lea    eventMsg(PC),a0
  563.     move.l    (a0),-(SP)    ; push contents of last event msg
  564.     jmp    donext(PC)
  565. *
  566. ; FIND-WINDOW ( point -- region, wptr )
  567.     dcode    FIND-WINDOW,x,ftemsg,findw
  568.     popd0
  569.     clr.w    -(SP)
  570.     pushd0
  571.     pea    ftwork1(PC)
  572.     _FindWindow
  573.     clr.w    -(SP)
  574.     lea    ftwork1(PC),a0
  575.     move.l    (a0),d0
  576.     sub.l    a3,d0
  577.     pushd0
  578.     jmp    donext(PC)
  579.     dcode    INIT-TOOLS,x,findw,intool
  580.     _InitFonts
  581.     move.l    #$ffff,d0    ; every event rfl 10/89
  582.     _FlushEvents
  583.     _InitWindows
  584.     _TEInit
  585.     pea    EWRM(PC)    ; warm start for Resume button
  586. ;in deep shit
  587.     _InitDialogs
  588.     clr.l    -(SP)    ; for windowPtr return
  589.     move.w    #256,-(SP)    ; window ID
  590.     pea    wrecord(PC)
  591.     move.l    #-1,-(SP)    ; POINTER(-1) for front window
  592.     _GetNewWindow    ; get window resource def
  593.     _setPort        ; setPort(WindowPtr)
  594.     lea    wrecord(PC),a0
  595.     move.w    #9,txSize(a0)    ; window text size = 9
  596.     move.w    #4,txfont(a0)    ; window text font
  597.     lea    pRect(PC),a1
  598.     move.l    portRect(a0),(a1)
  599.     move.l    portRect+4(a0),4(a1)
  600.     clr.l    -(SP)
  601.     _NewRgn
  602.     lea    aRegn(PC),a0
  603.     move.l    (SP)+,(a0)    ; fill in region handle
  604.     clr.w    -(SP)
  605.     _TextMode    ; source copy text mode
  606.     _Initmenus
  607.     _InitCursor
  608.     move.w    #$a09f,d0    ; check for trap availability
  609.     _getTrapAddress+$600
  610.     move.l    a0,d3    ; d3 = unimplemented trap addr
  611.     move.w    #$a860,d0
  612.     _getTrapAddress+$600
  613.     cmp.l    a0,d3    ; if <> waitnextevent is avail
  614.     sne    d0
  615.     move.b    d0,wneavail9+3-origin(a3)
  616.     move.l    #$a198,d0    ; get hwpriv trap addr
  617.     _getTrapAddress+$200
  618.     cmp.l    a0,d3    ; if <> hwpriv is avail
  619.     sne    d0
  620.     move.b    d0,hwpavail9+3-origin(a3)
  621.     jmp    donext(PC)
  622. *
  623.     dcode    HOME,x,intool,home
  624. dohome    move.l    #$f0008,d0
  625.     pushd0
  626.     _MoveTo        ; home
  627.     jmp    donext(PC)
  628. *
  629.     dcode    CLS,x,home,cls
  630.     pea    pRect(PC)
  631.     _EraseRect
  632.     jmp    dohome(PC)
  633.     jmp    donext(PC)
  634. *
  635.     dcode    SCROLL,x,cls,scroll    ; (dh dv --- )
  636.     popd0
  637.     popd1
  638.     pea    pRect(PC)
  639.     move.w    d1,-(SP)
  640.     move.w    d0,-(SP)
  641.     lea    aregn(PC),a0    ; get dummy region handle
  642.     move.l    (a0),-(SP)
  643.     _ScrollRect
  644.     jmp    donext(PC)
  645. *
  646.     dcode    >ORIGIN,x,scroll,setorg
  647.     popd0
  648.     addq.l    #2,SP
  649.     move.w    d0,-(SP)
  650.     _SetOrigin
  651.     jmp    donext(PC)
  652. *
  653.     dcode    LINE,x,setorg,xline    ; (dh dv ---)
  654.     popd0
  655.     addq.l    #2,SP
  656.     move.w    d0,-(SP)
  657.     _Line
  658.     jmp    donext(PC)
  659. *
  660.     dcode    LINETO,x,xline,xline2    ; (x y --)
  661.     popd0
  662.     addq.l    #2,SP
  663.     move.w    d0,-(sp)
  664.     _LineTo
  665.     jmp    donext(PC)
  666. *
  667.     dcode    LIT,x,xline2,lit ; build code header
  668.     move.l    (a4)+,-(SP)    ; push value at IP to stack
  669.     jmp    donext(PC)
  670. *
  671.     dcode    WLIT,x,lit,wlit    ; build code header
  672.     move.w    (a4)+,-(SP)    ; push value at IP to stack
  673.     clr.w    -(SP)    ; extend to 32 bits
  674.     jmp    donext(PC)
  675. *
  676.     dcode    WLITW,x,wlit,wlitw    ; build code header
  677.     move.w    (a4)+,-(sp)    ; push value at IP to stack
  678.     jmp    donext(PC)    ; no extend
  679. *    
  680.     dcode    W@(IP),x,wlitw,wfetip
  681.     move.l    (a6),d0    ; get IP from 1 nest back
  682.     move.w    0(a3,d0.l),-(SP)    ; push the word
  683.     clr.w    -(SP)
  684.     add.l    #2,(a6)    ; increment old IP past word
  685.     jmp    donext(PC)
  686. *
  687.     dcode    EXECUTE,x,wfetip,exec
  688.     move.l    (SP)+,d6    ; pop address to execute
  689.     move.l    0(a3,d6.l),d7    ; get contents of CFA
  690.     jmp    0(a3,d7.l)    ; execute the code
  691. *
  692.     dcode    TRAP,x,exec,trap_    ; execute passed-in Tool trap
  693.     popD0        ; get trap in d0
  694.     lea    trapword(PC),a0
  695.     move.w    d0,(a0)    ; store trap inline for execution
  696.     nop        ; so we don't get burned by prefetch
  697. trapword    DC.W    $A997    ; start with openresfile
  698.     jmp    donext(PC)
  699. *
  700.     dcode    GOTOXY,x,trap_,gotoxy
  701.     popd0        ; get Y in d0
  702.     addq.l    #2,SP    ; drop high-level word on stack
  703.     move.w    d0,-(SP)
  704.     _MoveTo        ; call Quickdraw to move pen
  705.     jmp    donext(PC)
  706. *
  707.     dcode    BEEP,x,gotoxy,beep    ; ( dur -- )
  708.     addq.l    #2,sp
  709.     _sysbeep
  710.     jmp    donext(PC)
  711. *
  712.     dcode    @XY,x,beep,fetxy    ; return X,Y pen location
  713.     pea    ftwork(PC)
  714.     _GetPen
  715.     lea    ftwork(PC),a0
  716.     clr.l    d0
  717.     move.w    2(a0),d0
  718.     pushd0        ; push X value
  719.     move.w    (a0),d0
  720.     pushd0        ; push Y value
  721.     jmp    donext(PC)
  722. *
  723.     dcode    BRANCH,x,fetxy,bran
  724.     adda.l    (a4),a4    ; add relative offset to IP
  725.     jmp    donext(PC)
  726. *
  727.     dcode    0BRANCH,x,bran,bran0
  728.     move.l    (SP)+,d0    ; pop data stack into d0
  729.     bne    br1    ; if non-0, ignore branch following
  730.     adda.l    (a4),a4    ; else take the branch
  731.     bra.s    br2
  732. br1    addq.l    #4,a4    ; next 32-bit cfa
  733. br2    jmp    donext(PC)
  734. *
  735.     dcode    OFBR,x,bran0,ofbr    ; 0branch used by OF clauses
  736.     move.l    (SP)+,d0    ; pop data stack into d0
  737.     bne    ofbr1    ; if non-0, ignore branch
  738.     move.l    (a6),d1    ; get IP from return stack
  739.     move.l    0(a3,d1.l),d2
  740.     add.l    d2,(a6)    ; add to stacked IP
  741.     bra.s    ofbr2
  742. ofbr1    addq.l    #4,(a6)    ; next 32-bit cfa 1 nest back
  743.     addq.l    #4,SP    ; drop the value
  744. ofbr2    jmp    donext(PC)
  745. *
  746.     dcode    FAKE,x,ofbr,fake_    ; use as a breakpoint with debugg
  747.     jmp    *(PC)
  748.     jmp    donext(PC)
  749. *
  750.     dcode    (LOOP),x,fake_,loop_    ; (loop)
  751.     addq.l    #1,(a6)    ; bump index (long)
  752.     move.l    (a6),d0
  753.     cmp.l    4(a6),d0    ; compare index to limit
  754.     bge    xloop1
  755.     adda.l    (a4),a4    ; branch back to top of loop
  756.     jmp    donext(PC)
  757. xloop1    addq.l    #8,a6    ; pop index,limit from return stack
  758.     addq.l    #4,a4
  759.     jmp    donext(PC)
  760. *
  761.     dcode    (DO),x,loop_,do_    ; this DO terminates on limit=count
  762.     move.l    (SP),d0
  763.     cmp.l    4(SP),d0    ; does limit=count? if so, terminate
  764.     bne    doloop
  765.     adda.l    (a4),a4    ; forward jump IP
  766.     addq.l    #8,SP
  767.     jmp    donext(PC)
  768. doloop    move.l    4(SP),-(a6)    ; limit val to Return stack
  769.     move.l    d0,-(a6)    ; start val
  770.     addq.l    #4,a4    ; skip the jump addr
  771.     addq.l    #8,SP
  772.     jmp    donext(PC)
  773. *
  774.     dcode    (LOOP+),x,do_,ploop_
  775.     move.l    (SP)+,d0
  776.     bmi    xploop1
  777.     add.l    d0,(a6)
  778.     move.l    (a6),d0
  779.     cmp.l    4(a6),d0
  780.     bge    xploop2
  781.     adda.l    (a4),a4
  782.     bra.s    xploop3
  783. xploop1    add.l    D0,(a6)
  784.     move.l    (a6),d0
  785.     cmp.l    4(a6),d0
  786.     ble    xploop2
  787.     adda.l    (a4),a4
  788.     bra.s    xploop3
  789. xploop2    addq.l    #8,a6
  790.     addq.l    #4,a4
  791. xploop3    jmp    donext(PC)
  792. *
  793.     dcode    I,x,ploop_,i
  794.     move.l    (a6),-(SP)
  795.     jmp    donext(PC)
  796. *
  797.     dcode    I+,x,i,iplus    ; add I to top of stack
  798.     move.l    (a6),d0
  799.     add.l    d0,(SP)
  800.     jmp    donext(PC)
  801. *
  802.     dcode    I-,x,iplus,iminus
  803.     move.l    (a6),d0
  804.     sub.l    d0,(SP)
  805.     jmp    donext(PC)
  806. *
  807.     dcode    I@,x,iminus,ifetch    ; fetch from I as addr
  808.     move.l    (A6),d7
  809.     move.l    0(a3,d7.l),-(sp)
  810.     jmp    donext(PC)
  811. *
  812.     dcode    I!,x,ifetch,istore
  813.     move.l    (A6),d7
  814.     move.l    (SP)+,0(a3,d7.l)
  815.     jmp    donext(PC)
  816. *
  817.     dcode    IC@,x,istore,icfet
  818.     clr.l    d0
  819.     move.l    (a6),d7
  820.     move.b    0(a3,d7.l),d0
  821.     move.l    d0,-(SP)
  822.     jmp    donext(PC)
  823. *
  824.     dcode    IC!,x,icfet,icstor
  825.     move.l    (A6),d7
  826.     move.l    (sp)+,d0
  827.     move.b    d0,0(a3,d7.l)
  828.     jmp    donext(PC)
  829. *
  830.     dcode    J,x,icstor,j
  831.     move.l    8(a6),-(SP)
  832.     jmp    donext(PC)
  833. *
  834.     dcode    DIGIT,x,j,digit
  835.     popd0
  836.     popd1
  837.     clr.l    d2
  838.     subi.l    #$30,d1
  839.     bmi    dig2
  840.     cmpi.l    #$0a,d1
  841.     bmi    dig1
  842.     subq.l    #7,d1
  843.     cmpi.l    #$0a,d1    ; to fix FIG bug that lets 58-64 pass
  844.     bmi    dig2
  845. dig1    cmp.l    d0,d1
  846.     bge    dig2
  847.     moveq    #1,d2
  848.     pushd1
  849. dig2    pushd2
  850.     jmp    donext(PC)
  851. *
  852.     dcode    TRAVERSE,x,digit,traver
  853.     popd0
  854.     popd1
  855.     moveq    #$20,d2
  856.     lea    0(a3,d1.l),a0
  857.     tst.l    d0
  858.     bmi    trav1
  859.     move.b    (a0),d0
  860.     andi.l    #$1f,d0
  861.     adda.l    d0,a0
  862.     move.l    a0,d0
  863.     andi.l    #1,d0
  864.     suba.l    d0,a0
  865.     addq.l    #1,a0
  866.     bra.s    trav2
  867. trav1    tst.b    (a0)
  868.     bmi    trav2
  869.     subq.l    #1,d2    ; exit early if drags on
  870.     beq    trav2
  871.     subq.l    #1,a0
  872.     bra.s    trav1
  873. trav2    suba.l    a3,a0
  874.     move.l    a0,-(SP)
  875.     jmp    donext(PC)
  876. *
  877.     dcode    (FIND),x,traver,find_
  878.     clr.l    d1
  879.     move.l    (SP)+,d7
  880.     lea    0(a3,d7.l),a0
  881. pfind1    movea.l    a0,a2
  882.     move.l    (SP),d7
  883.     lea    0(a3,d7.l),a1
  884.     move.b    (a2)+,d1
  885.     andi.l    #$03f,d1
  886.     cmp.b    (a1)+,d1
  887.     bne    pfind3
  888.     move.l    d1,d0
  889. pfind2    cmpm.b    (a1)+,(a2)+
  890.     bne    pfind3
  891.     subq.l    #1,d0
  892.     bne.s    pfind2
  893.     bsr    odd
  894.     addq.l    #8,a2
  895.     suba.l    a3,a2
  896.     move.l    a2,(SP)
  897.     move.b    (a0),d0
  898.     pushD0
  899.     moveq    #1,d0
  900.     bra.s    pfind4
  901. pfind3    movea.l    a0,a2
  902.     andi.w    #$1f,d1
  903.     adda.l    d1,a2
  904.     addq.l    #1,a2
  905.     bsr    odd
  906.     move.l    (a2),d7
  907.     lea    0(a3,d7.l),a0
  908.     tst.l    (a2)
  909.     bne.s    pfind1
  910.     addq.l    #4,SP
  911.     clr.l    d0
  912. pfind4    pushD0
  913.     jmp    donext(PC)
  914. odd    move.l    a2,d0
  915.     moveq    #1,d1
  916.     and.l    d1,d0
  917.     adda.l    d0,a2
  918.     rts
  919. *
  920. ; ( SelPfa ^class -- f OR 1cfa t)
  921.     dcode    ((FINDM)),x,find_,findm_
  922.     move.l    (SP)+,d7    ; get relative ^class
  923.     move.l    (SP)+,d0    ; get SelPfa to match
  924.     move.l    0(a3,d7.l),d7    ; get contents of ^methods link field
  925. findm0    lea    0(a3,d7.l),a1    ; get absolute ^methods dict nfa
  926. findm1    cmp.w    (a1),d0    ; is this the method we want?
  927.     beq    foundm    ; yes, we found the method
  928.     move.l    2(a1),d7    ; link to previous method entry
  929.     beq    notfndm    ; end of methods dict - not found
  930.     bra.s    findm0
  931. foundm    addi.l    #10,d7    ; point to 1cfa of method
  932.     move.l    d7,-(SP)    ; push 1cfa to stack
  933.     move.l    #1,-(SP)    ; true
  934.     bra.s    fmexit    ; return to Forth
  935. notFndm    clr.l    -(SP)
  936. fmexit    jmp    donext(PC)
  937. *
  938. *    ( addr delim -- addr n1 n2 n3 )
  939.     dcode    ENCLOSE,x,findm_,enclos
  940.     popd0        ; get delim in d0
  941.     move.l    (SP),d7    ; addr in d7
  942.     lea    0(a3,d7.l),a0    ; a0 has abs addr
  943.     clr.l    d1
  944. encGet    move.b    (a0)+,d2    ; get next byte in d2
  945.     beq    encNull    ; null - unconditional exit
  946.     cmpi.b    #9,d2    ; is char a Tab?
  947.     bne    notab1
  948.     move.b    #32,d2    ; map tabs to spaces
  949. notab1    cmp.b    d0,d2    ; does first char = delim?
  950.     bne    encNext    ; no
  951.     addq.l    #1,d1    ; get another char
  952.     bra.s    encGet
  953. encNull    pushd1        ; found null- push idx at null
  954.     addq.l    #1,d1    ; push idx of byte following
  955.     pushd1
  956.     bra.s    encl5    ; exit
  957. encNext    pushd1        ; idx of first non-delim
  958.     subq.l    #1,a0
  959. encl3    move.b    (a0)+,d2
  960.     beq    encl4
  961.     cmp.b    #9,d2    ; is char a Tab?
  962.     bne    notab2
  963.     move.b    #32,d2    ; map tabs to spaces
  964. notab2    cmp.b    d0,d2
  965.     beq    encl4
  966.     addq.l    #1,d1
  967.     bra.s    encl3
  968. encl4    move.l    d1,-(SP)
  969.     tst.b    d2
  970.     beq    encl5
  971.     addq.l    #1,d1
  972. encl5    pushd1        ; push unexamined idx and leave
  973.     jmp    donext(PC)
  974. *
  975.     dcode    (S=),x,enclos,sequ_    ; ( addr addr len -- b)
  976.     popd0        ; get length of string comparison
  977.     subq.l    #1,d0    ; setup counter for dbeq
  978.     movea.l    (SP)+,a0
  979.     movea.l    (SP)+,a1
  980.     adda.l    a3,a0
  981.     adda.l    a3,a1
  982. dosequ    cmpm.b    (a0)+,(a1)+
  983.     dbne    d0,dosequ
  984.     cmp.w    #-1,d0
  985.     beq    xsequ    ; counter was exhausted, so true
  986.     clr.l    -(SP)    ; push false
  987.     bra.s    nextsequ
  988. xsequ    move.l    #1,-(SP)    ; push true
  989. nextsequ    jmp    donext(PC)
  990. *
  991.     dcode    CMOVE,x,sequ_,cmove
  992. docmove    move.l    (SP)+,d0
  993.     movea.l    (SP)+,a1
  994.     movea.l    (SP)+,a0
  995.     adda.l    a3,a0
  996.     adda.l    a3,a1
  997. cmov1    _BlockMove
  998.     jmp    donext(PC)
  999. *
  1000. ; the somewhat dreaded multiply routines
  1001. mpy    move.l    (SP)+,-(a6)    ; save return address from jsr
  1002.     tst.w    (SP)    ; try short multiply first
  1003.     bne    mpy1
  1004.     tst.w    4(SP)    ; if both high words=0, we
  1005.     bne    mpy1    ; can do a short multiply
  1006.     popd0
  1007.     popd1
  1008.     mulu    d0,d1
  1009.     pushd1
  1010.     clr.l    d1
  1011.     pushd1
  1012.     move.l    (a6)+,-(SP)
  1013.     rts
  1014. mpy1    popd0        ; this is long multiply
  1015.     popd1
  1016.     moveq    #0,d2
  1017.     move.l    d2,-(SP)
  1018.     move.l    d2,-(SP)
  1019.     move.w    d1,d2
  1020.     mulu    d0,d2
  1021.     move.l    d2,4(SP)
  1022.     move.l    d1,d2
  1023.     swap    d2
  1024.     mulu    d0,d2
  1025.     add.l    d2,2(SP)
  1026.     swap    d0
  1027.     move.w    d1,d2
  1028.     mulu    d0,d2
  1029.     add.l    d2,2(SP)
  1030.     bcc    mpy2
  1031.     addq.w    #1,(SP)
  1032. mpy2    move.l    d1,d2
  1033.     swap    d2
  1034.     mulu    d0,d2
  1035.     add.l    d2,(SP)
  1036.     move.l    (a6)+,-(SP)
  1037.     rts
  1038. smpy    move.l    (SP)+,-(a6)
  1039.     tst.l    (SP)    ; signed multiply
  1040.     smi    d4
  1041.     bpl    smpy1
  1042.     neg.l    (SP)
  1043. smpy1    tst.l    4(SP)
  1044.     smi    d3
  1045.     bpl    smpy2
  1046.     neg.l    4(SP)
  1047. smpy2    eor.b    d3,d4
  1048.     bsr.s    mpy
  1049.     tst.b    d4
  1050.     beq    smpy3
  1051.     neg.l    4(SP)
  1052.     negx.l    (SP)
  1053. smpy3    move.l    (a6)+,-(SP)
  1054.     rts
  1055. xdiv    move.l    (SP)+,-(a6)
  1056.     tst.l    (SP)
  1057.     beq    div5
  1058.     tst.w    (SP)
  1059.     bne    longdiv
  1060.     tst.l    4(SP)
  1061.     bne    longdiv
  1062.     move.l    (SP)+,d2
  1063.     popd0
  1064.     popd1
  1065.     divu    d2,d1
  1066.     bvs    long1
  1067.     clr.l    d2
  1068.     move.w    d1,d2
  1069.     clr.w    d1
  1070.     swap    d1
  1071.     pushd1
  1072.     move.l    d2,-(SP)
  1073.     move.l    (a6)+,-(SP)
  1074.     rts
  1075. longdiv    move.l    (SP)+,d2    ; the dreaded long division
  1076.     popd0
  1077.     popd1
  1078. long1    moveq    #32,d3
  1079.     sub.l    d2,d0
  1080. div1    bmi    div2
  1081.     ori.l    #1,d1
  1082.     subq.w    #1,d3
  1083.     bmi    div3
  1084.     asl.l    #1,d1
  1085.     roxl.l    #1,d0
  1086.     sub.l    d2,d0
  1087.     bra.s    div1
  1088.     
  1089. div2    subq.w    #1,d3
  1090.     bmi    div3
  1091.     asl.l    #1,d1
  1092.     roxl.l    #1,d0
  1093.     add.l    d2,d0
  1094.     bra.s    div1
  1095. div3    tst.l    d0
  1096.     bpl    div4
  1097.     add.l    d2,d0
  1098. div4    pushd0
  1099.     pushd1
  1100.     move.l    (a6)+,-(SP)
  1101.     rts
  1102. div5    addq.l    #4,SP
  1103.     move.l    d2,4(SP)
  1104.     move.l    #$7fffffff,(SP)
  1105.     move.l    (a6)+,-(SP)
  1106.     rts
  1107. sdiv    move.l    (SP)+,-(a6)    ; save return address from jsr
  1108.     tst.l    (SP)    ; signed divide
  1109.     smi    d4
  1110.     bpl    sdiv1
  1111.     neg.l    (SP)
  1112. sdiv1    tst.l    4(SP)
  1113.     smi    d7
  1114.     bpl    sdiv2
  1115.     neg.l    8(SP)
  1116.     negx.l    4(SP)
  1117. sdiv2    eor.b    d4,d7
  1118.     bsr    xdiv
  1119.     tst.b    d7
  1120.     beq    sdiv3
  1121.     neg.l    (SP)
  1122. sdiv3    tst.b    d4
  1123.     beq    sdiv4
  1124.     neg.l    4(SP)
  1125. sdiv4    move.l    (a6)+,-(SP)
  1126.     rts
  1127. slmod    move.l    (SP)+,-(a6)
  1128.     moveq    #0,d1
  1129.     popd0
  1130.     tst.l    (SP)
  1131.     bpl    slmod1
  1132.     subq.l    #1,d1
  1133. slmod1    pushd1
  1134.     pushd0
  1135.     move.l    (a6)+,-(SP)
  1136.     bra.s    sdiv
  1137. *
  1138.     dcode    U*,x,cmove,ustar
  1139.     bsr    mpy
  1140.     jmp    donext(PC)
  1141. *
  1142.     dcode    U/,x,ustar,uslash
  1143.     bsr    xdiv
  1144.     jmp    donext(PC)
  1145. *
  1146.     dcode    M*,x,uslash,mstar
  1147.     bsr    smpy
  1148.     jmp    donext(PC)
  1149. *
  1150.     dcode    M/,x,mstar,mslash
  1151.     bsr    sdiv
  1152.     jmp    donext(PC)
  1153. *
  1154.     dcode    */,x,mslash,starsla
  1155.     move.l    (SP)+,-(a6)
  1156.     bsr    smpy
  1157.     move.l    (a6)+,-(SP)
  1158.     bsr    sdiv
  1159.     move.l    (SP)+,(SP)
  1160.     jmp    donext(PC)
  1161. *
  1162.     dcode    */MOD,x,starsla,ssmod
  1163.     move.l    (SP)+,-(a6)
  1164.     bsr    smpy
  1165.     move.l    (a6)+,-(SP)
  1166.     bsr    sdiv
  1167.     jmp    donext(PC)
  1168. *
  1169.     dcode    M/MOD,x,ssmod,msmod
  1170.     move.l    (SP)+,-(a6)
  1171.     moveq    #0,d0
  1172.     pushd0
  1173.     move.l    (a6),-(SP)
  1174.     bsr    xdiv
  1175.     move.l    (a6)+,d0
  1176.     move.l    (SP)+,-(a6)
  1177.     pushd0
  1178.     bsr    xdiv
  1179.     move.l    (a6)+,-(SP)
  1180.     jmp    donext(PC)
  1181. *
  1182.     dcode    *,x,msmod,star    ; *
  1183.     bsr    smpy
  1184.     addq.l    #4,SP    ; drop top of stack
  1185.     jmp    donext(PC)
  1186. *
  1187.     dcode    /,x,star,slash    ; /
  1188.     bsr    slmod
  1189.     move.l    (SP)+,(SP)
  1190.     jmp    donext(PC)
  1191. *
  1192.     dcode    /MOD,x,slash,xslmod    ; /MOD
  1193.     bsr    slmod
  1194.     jmp    donext(PC)
  1195. *
  1196.     dcode    MOD,x,xslmod,mod    ; MOD
  1197.     bsr    slmod
  1198.     addq.l    #4,SP
  1199.     jmp    donext(PC)
  1200. *
  1201.     dcode    D>,x,mod,dgrt    ; D>
  1202.     moveq    #1,d0
  1203.     move.l    8(SP),d1
  1204.     cmp.l    (SP),d1
  1205.     bgt    dgrt1
  1206.     move.l    12(SP),d1
  1207.     cmp.l    4(SP),d1
  1208.     bgt    dgrt1
  1209.     moveq    #0,d0
  1210. dgrt1    adda.l    #16,SP
  1211.     pushd0
  1212.     jmp    donext(PC)
  1213. *
  1214.     dcode    D<,x,dgrt,dless    ; D<
  1215.     moveq    #1,d0
  1216.     move.l    8(SP),d1
  1217.     cmp.l    (SP),d1
  1218.     blt    dless1
  1219.     move.l    12(SP),d1
  1220.     cmp.l    4(SP),d1
  1221.     blt    dless1
  1222.     moveq    #0,d0
  1223. dless1    adda.l    #16,SP
  1224.     pushd0
  1225.     jmp    donext(PC)
  1226. *
  1227.     dcode    D=,x,dless,dequ    ; D=
  1228.     move.l    (SP),d1
  1229.     cmp.l    8(SP),d1
  1230.     seq    d0
  1231.     move.l    4(SP),d1
  1232.     cmp.l    12(SP),d1
  1233.     seq    d1
  1234.     adda.l    #16,SP
  1235.     and.l    d1,d0
  1236.     bra    setbyt
  1237.     jmp    donext(PC)
  1238. *
  1239.     dcode    U<,x,dequ,uless
  1240.     cmp2
  1241.     scs    d0
  1242.     bra.s    setbyt
  1243. *
  1244.     dcode    U>,x,uless,ugrt
  1245.     cmp2
  1246.     scc    d0
  1247.     bra.s    setbyt
  1248. *
  1249.     dcode    <,x,ugrt,less    ; <
  1250.     cmp2
  1251.     slt    d0
  1252.     bra.s    setbyt
  1253. *
  1254.     dcode    >,x,less,grt    ; >
  1255.     cmp2
  1256.     sgt    d0
  1257.     bra.s    setbyt
  1258. *
  1259.     dcode    =,x,grt,equals    ; =
  1260.     cmp2
  1261.     seq    d0
  1262.     bra.s    setbyt
  1263. *
  1264.     dcode    <>,x,equals,nequals
  1265.     cmp2
  1266.     sne    d0
  1267.     bra.s    setbyt
  1268. *
  1269.     dcode    0=,x,nequals,zequ
  1270.     tst.l    (SP)+
  1271.     seq    d0
  1272.     bra.s    setbyt
  1273. *
  1274.     dcode    0<,x,zequ,zless
  1275.     tst.l    (SP)+
  1276.     smi    d0
  1277. setbyt    moveq    #1,d1
  1278.     and.l    d1,d0
  1279.     pushD0
  1280.     jmp    donext(PC)
  1281. *
  1282.     dcode    0>,x,zless,zgrt
  1283.     tst.l    (SP)+
  1284.     sgt    d0
  1285.     bra.s    setbyt
  1286. *
  1287.     dcode    <=,x,zgrt,lesequ
  1288.     cmp2
  1289.     sle    d0
  1290.     bra.s    setbyt
  1291. *
  1292.     dcode    >=,x,lesequ,grtequ
  1293.     cmp2
  1294.     sge    d0
  1295.     bra.s    setbyt
  1296. *
  1297.     dcode    0!,x,grtequ,zstore    ; store 0 at addr
  1298.     move.l    (sp)+,d7
  1299.     clr.l    0(a3,d7.l)
  1300.     jmp    donext(PC)
  1301. *
  1302.     dcode    0,x,zstore,pzer    ; short, fast 0 word
  1303.     clr.l    -(SP)
  1304.     jmp    donext(PC)
  1305. *
  1306.     dcode    1,x,pzer,pone    ; short, fast 1 word
  1307.     move.l    #1,-(SP)
  1308.     jmp    donext(PC)
  1309. *
  1310.     dcode    -1,x,pone,pmone    ; short, fast -1 word
  1311.     move.l    #-1,-(SP)
  1312.     jmp    donext(PC)
  1313. *
  1314.     dcode    2,x,pmone,ptwo    ; short, fast 2 word
  1315.     move.l    #2,-(SP)
  1316.     jmp    donext(PC)
  1317. *
  1318.     dcode    4,x,ptwo,pfour
  1319.     move.l    #4,-(SP)
  1320.     jmp    donext(PC)
  1321. *
  1322.     dcode    AND,x,pfour,and_
  1323.     popD0
  1324.     and.l    d0,(SP)
  1325.     jmp    donext(PC)
  1326. *
  1327.     dcode    LAND,x,and_,land_
  1328.     popd0
  1329.     tst.l    (SP)
  1330.     beq    land2
  1331.     move.l    #1,(SP)
  1332.     tst.l    d0
  1333.     beq    land1
  1334.     moveq    #1,d0
  1335. land1    and.l    d0,(SP)
  1336. land2    jmp    donext(PC)
  1337. *
  1338.     dcode    OR,x,land_,or_
  1339.     popD0
  1340.     or.l    d0,(SP)
  1341.     jmp    donext(PC)
  1342. *
  1343.     dcode    LOR,x,or_,lor_
  1344.     popd0
  1345.     tst.l    d0
  1346.     beq    lor1
  1347.     moveq    #1,d0
  1348. lor1    tst.l    (SP)
  1349.     beq    lor2
  1350.     move.l    #1,(SP)
  1351. lor2    or.l    d0,(SP)
  1352.     jmp    donext(PC)
  1353. *
  1354.     dcode    XOR,x,lor_,xor
  1355.     popD0
  1356.     eor.l    d0,(SP)
  1357.     jmp    donext(PC)
  1358. *
  1359.     dcode    LXOR,x,xor,lxor
  1360.     popd0
  1361.     tst.l    d0
  1362.     beq    lxor1
  1363.     moveq    #1,d0
  1364. lxor1    tst.l    (SP)
  1365.     beq    lxor2
  1366.     move.l    #1,(SP)
  1367. lxor2    eor.l    d0,(SP)
  1368.     jmp    donext(PC)
  1369. *
  1370.     dcode    HERE,x,lxor,here
  1371.     move.l    #(dp9-origin),d7
  1372.     move.l    0(a3,d7.l),-(SP)
  1373.     jmp    donext(PC)
  1374. *
  1375.     dcode    ALLOT,x,here,allot
  1376.     move.l    #(dp9-origin),d7
  1377.     popD0
  1378.     add.l    d0,0(a3,d7.l)    ; increment DP
  1379.     jmp    donext(PC)
  1380. *
  1381.     dcode    SP@,x,allot,spfet
  1382.     move.l    SP,d0
  1383.     sub.l    a3,d0
  1384.     pushD0
  1385.     jmp    donext(PC)
  1386. *
  1387.     dcode    SP!,x,spfet,spstor
  1388.     move.l    #(s09-origin),d7
  1389.     move.l    0(a3,d7.l),d7
  1390.     lea    0(a3,d7.l),SP    ; add a3 to it and store in SP
  1391.     jmp    donext(PC)
  1392. *
  1393.     dcode    RP@,x,spstor,rpfet
  1394.     move.l    a6,d0
  1395.     sub.l    a3,d0
  1396.     pushD0
  1397.     jmp    donext(PC)
  1398. *
  1399.     dcode    RP!,x,rpfet,rpstor
  1400.     move.l    #(r09-origin),d7
  1401.     move.l    0(a3,d7.l),d7
  1402.     lea    0(a3,d7.l),a6    ; add a3 to it and store in RP
  1403.     jmp    donext(PC)
  1404. *
  1405.     dcode    MP!,x,rpstor,mpstor
  1406.     move.l    initmp(PC),d5
  1407.     add.l    a3,d5    ; get initmp and add a3 to it
  1408.     jmp    donext(PC)
  1409. *
  1410.     dcode    MP@,x,mpstor,mpfet
  1411.     move.l    d5,d0
  1412.     sub.l    a3,d0
  1413.     pushD0
  1414.     jmp    donext(PC)
  1415. *
  1416.     dcode    THEPORT,x,mpfet,port_
  1417.     move.l    (a5),a0    ; Point to QD globals
  1418.     move.l    (a0),d0    ; point to current grafport
  1419.     sub.l    a3,d0
  1420.     pushd0
  1421.     jmp    donext(PC)
  1422. *
  1423.     dcode    (LCWORD),x,port_,lcword    ; doesn't map to upper ca
  1424.     popd0        ; d0=len to next word
  1425.     lea    in9(PC),a0
  1426.     add.l    d0,(a0)    ; bump IN
  1427.     popd0        ; d0=offs to end of parsed word
  1428.     popd1        ; d1=offs to beg of parsed word
  1429.     sub.w    d1,d0    ; d0=len this word
  1430.     lea    dp9(PC),a0
  1431.     movea.l    (a0),a0    ; a0=relative DP
  1432.     adda.l    a3,a0    ; a0=abs DP = HERE
  1433.     move.b    d0,(a0)    ; store len
  1434.     move.b    #32,1(a0,d0.l)    ; blank at end of word
  1435.     movea.l    (SP)+,a1    ; addr of string
  1436.     adda.l    a3,a1
  1437.     adda.l    d1,a1    ; a1=source address to move from
  1438. wMov    move.b    -1(a1,d0.w),0(a0,d0.w)    ; copy the string
  1439.     subq.l    #1,d0
  1440.     bne.s    wMov
  1441.     jmp    donext(PC)
  1442. *
  1443.     dcode    (WORD),x,lcword,word_    ; fast code for WORD
  1444.     popd0        ; d0=len to next word
  1445.     lea    in9(PC),a0
  1446.     add.l    d0,(a0)    ; bump IN
  1447.     popd0        ; d0=offs to end of parsed word
  1448.     popd1        ; d1=offs to beg of parsed word
  1449.     sub.w    d1,d0    ; d0=len this word
  1450.     lea    dp9(PC),a0
  1451.     movea.l    (a0),a0    ; a0=relative DP
  1452.     adda.l    a3,a0    ; a0=abs DP = HERE
  1453.     move.b    d0,(a0)    ; store len
  1454.     move.b    #32,1(a0,d0.l)    ; blank at end of word
  1455.     movea.l    (SP)+,a1    ; addr of string
  1456.     adda.l    a3,a1
  1457.     adda.l    d1,a1    ; a1=source address to move from
  1458. wordMov    move.b    -1(a1,d0.w),0(a0,d0.w)    ; copy the string
  1459.     cmpi.b    #96,0(a0,d0.w)
  1460.     ble    wordmov1    ; map to upper case
  1461.     cmpi.b    #123,0(a0,d0.w)
  1462.     bge    wordMov1
  1463.     subi.b    #32,0(a0,d0.w)
  1464. wordmov1    subq.l    #1,d0
  1465.     bne.s    wordMov
  1466.     jmp    donext(PC)
  1467. *
  1468.     dcode    (DODO),x,word_,dodo    ; code for mcfa words
  1469. dodo1    move.w    -2(a3,d7.l),d0    ; pickup len to child's pfa
  1470.     add.l    d0,d6    ; advance wp
  1471.     move.l    d6,-(sp)    ; push pfa for do> code
  1472.     suba.l    a3,a4
  1473.     move.l    a4,-(a6)    ; save old IP on RP
  1474.     lea    10(a3,d7.l),a4    ; point IP to threaded code
  1475.     jmp    donext(PC)
  1476. *
  1477. ; this code gets compiled before each piece of DO.. code (10 bytes long)
  1478.     dcode    DOJMP,x,dodo,dojmp
  1479.     move.l    #(dodo1-origin),d0
  1480.     jmp    0(a3,d0.l)
  1481. *
  1482. ; this code gets compiled into the front of each class definition
  1483. ; and is pointed to by the cfa of all objects
  1484.     dcode    DOOBJ,x,dojmp,doobj
  1485. obcode    addq.l    #4,d6    ; d6->pfa of object
  1486. dirObj    move.l    d6,-(SP)    ; push obj addr
  1487.     jmp    donext(PC)
  1488. *
  1489. ; this is the code pointed to by the cfa of all classes
  1490.     dcode    DOCLASS,x,doobj,dclass
  1491.     addq.l    #4,d6
  1492.     move.l    d6,-(SP)    ; push ^class on stack
  1493.     move.l    #(bldvec-origin),d6    ; d6 has cfa of BLDVEC
  1494.     move.l    0(a3,d6.l),d7    ; d7 has code addr of BLDVEC
  1495.     jmp    0(a3,d7.l)    ; do it
  1496. *
  1497. ; runtime code for a message to a public object
  1498.     dcode    M0CFA,x,dclass,zcfa
  1499.     movea.l    d5,a2
  1500.     clr.l    d0
  1501.     clr.l    d4
  1502.     move.l    (SP)+,d3    ; get obj addr in d3
  1503.     move.b    8(a3,d6.l),d0    ; pickup #args for named stack
  1504.     beq    noArgs
  1505.     addq.l    #2,d6    ; skip extra word for #args in method
  1506.     move.l    d0,d1    ; save #args
  1507.     lsr.b    #4,d0    ; get #temps nybble
  1508.     beq    noLocs    ; no local vars
  1509.     move.l    d0,d4    ; accum total #cells in d4
  1510.     lsl.b    #2,d0    ; compute #bytes = cells*4
  1511.     suba.l    d0,a2    ; allocate temp space
  1512. noLocs    andi.b    #$0f,d1    ; low nybble has #input parms
  1513.     beq    noIns    ; no input parms
  1514.     add.l    d1,d4
  1515. someArgs    move.l    (SP)+,-(a2)    ; pop data stack to methods stack
  1516.     subq.w    #1,d1
  1517.     bne.s    someArgs    ; transfer all args from data stack
  1518. noIns    move.l    d4,d0
  1519. noArgs    move.l    d0,-(a2)    ; push #args to methods stack
  1520.     move.l    d3,-(a2)    ; d3 has base address of local data
  1521.     move.l    a2,d5
  1522.     suba.l    a3,a4    ; Perform colcode
  1523.     move.l    a4,-(a6)
  1524.     addq.l    #8,d6
  1525.     lea    0(a3,d6.l),a4
  1526.     jmp    donext(PC)
  1527. *
  1528. ; runtime code for a message to a private ivar
  1529.     dcode    M1CFA,x,zcfa,onecfa
  1530.     move.l    d5,a2
  1531.     clr.l    d0
  1532.     clr.l    d4
  1533.     move.w    (a4)+,d0    ; get offset to ivar
  1534.     bge    notSelf    ; if negative, this is a Self reference
  1535.     clr.l    d0    ; if self, preserve base addr
  1536. notSelf    move.l    (a2),d2    ; get base address
  1537.     add.l    d0,d2    ; add offset to base address
  1538.     clr.w    d0
  1539.     move.b    4(a3,d6.l),d0    ; pickup #args for named stack
  1540.     beq    noArgs1
  1541.     addq.l    #2,d6    ; skip extra word for #args in method
  1542.     move.l    d0,d1    ; save #args
  1543.     lsr.b    #4,d0    ; get #temps nybble
  1544.     beq    nolocs1
  1545.     move.l    D0,D4    ; total #cells
  1546.     lsl.b    #2,d0    ; compute #bytes = cells*4
  1547.     suba.l    d0,a2    ; allocate temp space
  1548. noLocs1    andi.b    #$0f,d1    ; low nybble has #input parms
  1549.     beq    noins1
  1550.     add.l    d1,d4    ; save #input parms
  1551. args1    move.l    (SP)+,-(a2)    ; pop data stack to methods stack
  1552.     subq.w    #1,d1
  1553.     bne.s    args1    ; transfer all args from data stack
  1554. noins1    move.l    d4,d0
  1555. noArgs1    move.l    d0,-(a2)    ; push #args to methods stack
  1556.     move.l    d2,-(a2)    ; push offset+base to mstack
  1557. mNest    move.l    a2,d5
  1558.     suba.l    a3,a4    ; do colcode nest
  1559.     move.l    a4,-(a6)
  1560.     addq.l    #4,d6
  1561.     lea    0(a3,d6.l),a4
  1562.     jmp    donext(PC)
  1563. *
  1564.     dcode    (;M),x,onecfa,semim_    ; this is the ;m definition
  1565.     addq.l    #8,d5    ; pop two entries from mstack
  1566.     movea.l    d5,a2
  1567.     move.l    -4(a2),d0    ; look at #args
  1568.     beq    noPop
  1569.     lsl.w    #2,d0    ; setup to add #args*4
  1570.     adda.l    d0,a2    ; pop #args
  1571.     move.l    a2,d5
  1572. noPop    move.l    (a6)+,d7
  1573.     lea    0(a3,d7.l),a4
  1574.     jmp    donext(PC)
  1575. *
  1576.     dcode    ;S,x,semim_,semis    ; this is the ;S definition
  1577.     move.l    (a6)+,d7
  1578.     lea    0(a3,d7.l),a4
  1579.     jmp    donext(PC)
  1580. *
  1581.     dcode    COLP,x,semis,pcolon    ; named stack colon code
  1582. pcolcode    move.l    d5,a2
  1583.     clr.l    d0
  1584.     clr.l    d4
  1585.     move.b    4(a3,d6.l),d0    ; pickup #args for named stack
  1586.     beq    noArgs3
  1587.     addq.l    #2,d6    ; skip extra word for #args in method
  1588.     move.l    d0,d1    ; save #args
  1589.     lsr.b    #4,d0    ; get #temps nybble
  1590.     beq    noLocs3    ; no local vars
  1591.     move.l    d0,d4    ; accum total #cells in d4
  1592.     lsl.b    #2,d0    ; compute #bytes = cells*4
  1593.     sub.l    d0,a2    ; allocate temp space
  1594. NoLocs3    andi.b    #$0f,D1    ; low nybble has #input parms
  1595.     beq    noIns3    ; no input parms
  1596.     add.l    d1,d4
  1597. Args3    move.l    (SP)+,-(a2)    ; pop data stack to methods stack
  1598.     subq.w    #1,d1
  1599.     bne.s    Args3    ; transfer all args from data stack
  1600. noIns3    move.l    d4,d0
  1601. noArgs3    move.l    d0,-(a2)    ; push #args to methods stack
  1602.     clr.l    -(a2)    ; waste the objaddr cell
  1603.     move.l    a2,d5    ;
  1604.     suba.l    a3,a4    ; Perform colcode
  1605.     move.l    a4,-(a6)
  1606.     addq.l    #4,d6
  1607.     lea    0(a3,d6.l),a4
  1608.     jmp    donext(PC)
  1609. *
  1610.     dcode    (SEMIP),x,pcolon,semip    ; named stack denester co
  1611.     addq.l    #8,d5    ; pop two entries from mstack
  1612.     movea.l    d5,a2
  1613.     move.l    -4(a2),d0    ; look at #args
  1614.     beq    noPops1
  1615.     lsl.w    #2,d0    ; setup to add #args*4
  1616.     adda.l    d0,a2    ; pop #args
  1617.     move.l    a2,d5
  1618. nopops1    move.l    (a6)+,d7
  1619.     lea    0(a3,d7.l),a4
  1620.     jmp    donext(PC)
  1621. *
  1622.     dcode    LEAVE,x,semip,leave
  1623.     move.l    (a6),4(a6)
  1624.     jmp    donext(PC)
  1625. *
  1626.     dcode    >R,x,leave,toR
  1627.     move.l    (SP)+,-(a6)
  1628.     jmp    donext(PC)
  1629. *
  1630.     dcode    R>,x,toR,rFrom
  1631.     move.l    (a6)+,-(SP)
  1632.     jmp    donext(PC)
  1633. *
  1634.     dcode    R,x,rFrom,r
  1635.     move.l    (a6),-(SP)
  1636.     jmp    donext(PC)
  1637. *
  1638.     dcode    PUSHM,x,r,mpush
  1639.     exg    d5,a2
  1640.     move.l    (SP)+,-(a2)
  1641.     exg    d5,a2
  1642.     jmp    donext(PC)
  1643. *
  1644.     dcode    POPM,x,mpush,mpop
  1645.     exg    d5,a2
  1646.     move.l    (a2)+,-(SP)
  1647.     exg    d5,a2
  1648.     jmp    donext(PC)
  1649. *
  1650.     dcode    COPYM,x,mpop,mcopy
  1651.     move.l    d5,a2
  1652.     move.l    (a2),-(SP)
  1653.     jmp    donext(PC)
  1654. *
  1655.     dcode    EXGM,x,mcopy,mexg
  1656.     exg    d5,a2
  1657.     move.l    (SP),d0
  1658.     move.l    (a2),(SP)
  1659.     move.l    d0,(a2)
  1660.     jmp    donext(PC)
  1661. *
  1662.     dcode    DUPM,x,mexg,mdup
  1663. dupm    exg    d5,a2
  1664.     move.l    (a2),-(a2)
  1665.     exg    d5,a2
  1666.     jmp    donext(PC)
  1667. *
  1668.     dcode    ADDM,x,mdup,madd
  1669.     popd0
  1670. addmd0    exg    d5,a2    ; copied this from nucleus--suspect!
  1671.     add.l    d0,(a2)
  1672.     exg    d5,a2
  1673.     jmp    donext(PC)
  1674. *
  1675.     dcode    DROPM,x,madd,mdrop
  1676.     exg    d5,a2    ; *** popmd0
  1677.     move.l    (a2)+,d0
  1678.     exg    d5,a2
  1679.     jmp    donext(PC)
  1680. *
  1681.     dcode    MP0,x,mdrop,mp0    ; mstack picks for named parms
  1682.     move.l    d5,a2
  1683.     move.l    8(a2),-(SP)    ; push parm to data stack
  1684.     jmp    donext(PC)
  1685. *
  1686.     dcode    MP1,x,mp0,mp1    ; mstack picks for named parms
  1687.     move.l    d5,a2
  1688.     move.l    12(a2),-(SP)    ; push parm to data stack
  1689.     jmp    donext(PC)
  1690. *
  1691.     dcode    MP2,x,mp1,mp2    ; mstack picks for named parms
  1692.     move.l    d5,a2
  1693.     move.l    16(a2),-(SP)    ; push parm to data stack
  1694.     jmp    donext(PC)
  1695. *
  1696.     dcode    MP3,x,mp2,mp3    ; mstack picks for named parms
  1697.     move.l    d5,a2
  1698.     move.l    20(a2),-(SP)    ; push parm to data stack
  1699.     jmp    donext(PC)
  1700. *
  1701.     dcode    MP4,x,mp3,mp4    ; mstack picks for named parms
  1702.     move.l    d5,a2
  1703.     move.l    24(a2),-(SP)    ; push parm to data stack
  1704.     jmp    donext(PC)
  1705. *
  1706.     dcode    MP5,x,mp4,mp5    ; mstack picks for named parms
  1707.     move.l    d5,a2
  1708.     move.l    28(a2),-(SP)    ; push parm to data stack
  1709.     jmp    donext(PC)
  1710. *
  1711.     dcode    MS0,x,mp5,ms0    ; mstack stores for named parms
  1712.     move.l    d5,a2
  1713.     move.l    (SP)+,8(a2)    ; replace parm val with top of stack
  1714.     jmp    donext(PC)
  1715. *
  1716.     dcode    MS1,x,ms0,ms1    ; mstack stores for named parms
  1717.     move.l    d5,a2
  1718.     move.l    (SP)+,12(a2)    ; replace parm val with top of stack
  1719.     jmp    donext(PC)
  1720. *
  1721.     dcode    MS2,x,ms1,ms2    ; mstack stores for named parms
  1722.     move.l    d5,a2
  1723.     move.l    (SP)+,16(a2)    ; replace parm val with top of stack
  1724.     jmp    donext(PC)
  1725. *
  1726.     dcode    MS3,x,ms2,ms3    ; mstack stores for named parms
  1727.     move.l    d5,a2
  1728.     move.l    (SP)+,20(a2)    ; replace parm val with top of stack
  1729.     jmp    donext(PC)
  1730. *
  1731.     dcode    MS4,x,ms3,ms4    ; mstack stores for named parms
  1732.     move.l    d5,a2
  1733.     move.l    (SP)+,24(a2)    ; replace parm val with top of stack
  1734.     jmp    donext(PC)
  1735. *
  1736.     dcode    MS5,x,ms4,ms5    ; mstack stores for named parms
  1737.     move.l    d5,a2
  1738.     move.l    (SP)+,28(a2)    ; replace parm val with top of stack
  1739.     jmp    donext(PC)
  1740. *
  1741.     dcode    (++>),x,ms5,minc    ; increment named parm
  1742.     move.l    d5,a2
  1743.     move.w    (a4)+,d0    ; get element offset
  1744.     move.l    (sp)+,d1    ; get increment value
  1745.     add.l    d1,0(a2,d0.w)    ; increment the cell
  1746.     jmp    donext(PC)
  1747. *
  1748.     dcode    (EX>),x,minc,mdo    ; execute a procedural arg
  1749.     move.l    d5,a2
  1750.     move.w    (a4)+,d0    ; get offset to named parm
  1751.     move.l    0(a2,d0.w),d6    ; get the cfa
  1752.     move.l    0(a3,d6.l),d7    ; get the code
  1753.     jmp    0(a3,d7.l)
  1754. *
  1755.     dcode    +,x,mdo,plus
  1756.     popD0
  1757.     add.l    d0,(SP)
  1758.     jmp    donext(PC)
  1759. *
  1760.     dcode    -,x,plus,subt
  1761.     popD0
  1762.     sub.l    d0,(SP)
  1763.     jmp    donext(PC)
  1764. *
  1765.     dcode    MAX,x,subt,max
  1766.     popD0
  1767.     cmp.l    (SP),d0
  1768.     blt    maxq
  1769.     move.l    d0,(SP)
  1770. maxq    jmp    donext(PC)
  1771. *
  1772.     dcode    MIN,x,max,min
  1773.     popD0
  1774.     cmp.l    (SP),d0
  1775.     bgt    minq
  1776.     move.l    d0,(SP)
  1777. minq    jmp    donext(PC)
  1778. *
  1779.     dcode    NEGATE,x,min,minus
  1780. mins1    neg.l    (SP)
  1781.     jmp    donext(PC)
  1782. *
  1783.     dcode    DNEGATE,x,minus,dminus
  1784. dmins1    neg.l    4(SP)
  1785.     negx.l    (SP)
  1786.     jmp    donext(PC)
  1787. *
  1788.     dcode    CFA,x,dminus,cfa
  1789.     subq.l    #4,(SP)
  1790.     jmp    donext(PC)
  1791. *
  1792.     dcode    +-,x,cfa,plmin
  1793.     tst.l    (SP)+
  1794.     bmi.s    mins1
  1795.     jmp    donext(PC)
  1796. *
  1797.     dcode    ABS,x,plmin,abs
  1798.     tst.l    (SP)
  1799.     bmi.s    mins1
  1800.     jmp    donext(PC)
  1801. *
  1802.     dcode    DABS,x,abs,dabs
  1803.     tst.l    (SP)
  1804.     bmi.s    dmins1
  1805.     jmp    donext(PC)
  1806. *
  1807.     dcode    S->D,x,dabs,sToD
  1808.     moveq    #0,d0
  1809.     tst.l    (SP)
  1810.     bpl    GOHERE
  1811.     subq.l    #1,d0
  1812. GOHERE    pushd0
  1813.     jmp    donext(PC)
  1814. *
  1815.     dcode    OVER,x,sToD,over
  1816.     move.l    4(SP),-(SP)
  1817.     jmp    donext(PC)
  1818. *
  1819.     dcode    2OVER,x,over,over2
  1820.     move.l    12(SP),-(SP)
  1821.     move.l    12(SP),-(SP)
  1822.     jmp    donext(PC)
  1823. *
  1824.     dcode    DROP,x,over2,drop
  1825.     addq.l    #4,SP
  1826.     jmp    donext(PC)
  1827. *
  1828.     dcode    2DROP,x,drop,drop2
  1829.     addq.l    #8,SP
  1830.     jmp    donext(PC)
  1831. *
  1832.     dcode    SWAP,x,drop2,swap_
  1833.     popD0
  1834.     move.l    (SP),d1
  1835.     move.l    d0,(SP)
  1836.     pushD1
  1837.     jmp    donext(PC)
  1838. *
  1839.     dcode    2SWAP,x,swap_,swap2
  1840.     popD0
  1841.     popD1
  1842.     move.l    (SP)+,d3
  1843.     move.l    (SP),d4
  1844.     move.l    d1,(SP)
  1845.     move.l    d0,-(SP)
  1846.     move.l    d4,-(SP)
  1847.     move.l    d3,-(SP)
  1848.     jmp    donext(PC)
  1849. *
  1850.     dcode    DUP,x,swap2,dup
  1851.     move.l    (SP),-(SP)
  1852.     jmp    donext(PC)
  1853. *
  1854.     dcode    2DUP,x,dup,dup2
  1855.     move.l    4(SP),-(SP)
  1856.     move.l    4(SP),-(SP)
  1857.     jmp    donext(PC)
  1858. *
  1859.     dcode    -DUP,x,dup2,mindup
  1860.     tst.l    (SP)
  1861.     beq    ddup
  1862.     move.l    (SP),-(SP)
  1863. ddup    jmp    donext(PC)
  1864. *
  1865.     dcode    +!,x,mindup,plstor
  1866.     move.l    (SP)+,d7
  1867.     popD0
  1868.     add.l    d0,0(a3,d7.l)
  1869.     jmp    donext(PC)
  1870. *
  1871.     dcode    TOGGLE,x,plstor,toggle
  1872.     popD0
  1873.     move.l    (SP)+,d7
  1874.     eor.b    d0,0(a3,d7.l)
  1875.     jmp    donext(PC)
  1876. *
  1877.     dcode    W@,x,toggle,wfetch    ; this is a 16-bit fetch
  1878.     clr.l    d0
  1879.     move.l    (SP),d7
  1880.     move.w    0(a3,d7.l),d0
  1881.     move.l    d0,(SP)
  1882.     jmp    donext(PC)
  1883. *
  1884.     dcode    @,x,wfetch,fetch    ; this is a 32-bit fetch
  1885.     move.l    (SP),d7
  1886.     move.l    0(a3,d7.l),(SP)
  1887.     jmp    donext(PC)
  1888. *
  1889.     dcode    C@,x,fetch,cfetch
  1890.     clr.l    d0
  1891.     move.l    (SP),d7
  1892.     move.b    0(a3,d7.l),d0
  1893.     move.l    d0,(SP)
  1894.     jmp    donext(PC)
  1895. *
  1896.     dcode    MW@,x,cfetch,mwfetch    ; 16-bit fetch from mstack addr
  1897.     move.l    d5,a2
  1898.     clr.l    d0
  1899.     move.l    (a2),d7
  1900.     move.w    0(a3,d7.l),d0
  1901.     ext.l    d0    ; sign-extend
  1902.     move.l    d0,-(SP)
  1903.     jmp    donext(PC)
  1904. *
  1905.     dcode    M@,x,mwfetch,mfetch    ; this is a 32-bit fetch
  1906.     move.l    d5,a2
  1907.     move.l    (a2),d7
  1908.     move.l    0(a3,d7.l),-(SP)
  1909.     jmp    donext(PC)
  1910. *
  1911.     dcode    2@,x,mfetch,fetch2    ; ( double word fetch )
  1912.     move.l    (SP),d7
  1913.     lea    0(a3,d7.l),a0
  1914.     move.l    (a0)+,-(sp)
  1915.     move.l    (a0),4(SP)
  1916.     jmp    donext(PC)
  1917. *
  1918.     dcode    W!,x,fetch2,wstore    ; 16-bit store
  1919.     move.l    (SP)+,d7    ; address is relative to a3
  1920.     popD0        ; d0 has value
  1921.     move.w    d0,0(a3,d7.l)
  1922.     jmp    donext(PC)
  1923. *
  1924.     dcode    W+!,x,wstore,wpstore    ; 16-bit plus store
  1925.     move.l    (SP)+,d7
  1926.     popD0
  1927.     add.w    d0,0(a3,d7.l)
  1928.     jmp    donext(PC)
  1929. *
  1930.     dcode    !,x,wpstore,store    ; 32-bit store
  1931.     move.l    (SP)+,d7    ; address is relative to a3
  1932.     popD0        ; d0 has value
  1933.     move.l    d0,0(a3,d7.l)
  1934.     jmp    donext(PC)
  1935. *
  1936.     dcode    C!,x,store,cstore
  1937.     move.l    (SP)+,d7
  1938.     popD0
  1939.     move.b    d0,0(a3,d7.l)
  1940.     jmp    donext(PC)
  1941. *
  1942.     dcode    C+!,x,cstore,cpstore    ; 8 bit plus store
  1943.     move.l    (SP)+,d7
  1944.     popD0
  1945.     add.b    d0,0(a3,d7.l)
  1946.     jmp    donext(PC)
  1947. *
  1948.     dcode    MW!,x,cpstore,mwstore    ; 16-bit store to addr on mstack
  1949.     move.l    d5,a2
  1950.     move.l    (a2),d7    ; address is relative to a3
  1951.     popD0        ; d0 has value
  1952.     move.w    d0,0(a3,d7.l)
  1953.     jmp    donext(PC)
  1954. *
  1955.     dcode    M!,x,mwstore,mstore    ; 32-bit store to addr on mstack
  1956.     move.l    d5,a2
  1957.     move.l    (a2),d7    ; address is relative to a3
  1958.     popD0        ; d0 has value
  1959.     move.l    d0,0(a3,d7.l)
  1960.     jmp    donext(PC)
  1961. *
  1962.     dcode    2!,x,mstore,store2    ; ( double word store )
  1963.     move.l    (SP)+,d7
  1964.     lea    0(a3,d7.l),a0
  1965.     move.l    (SP)+,(a0)+
  1966.     move.l    (SP)+,(a0)
  1967.     jmp    donext(PC)
  1968. *
  1969.     dcode    D+,x,store2,dplus    ; 64-bit add
  1970.     popd0
  1971.     popd1
  1972.     move.l    (SP)+,d2
  1973.     move.l    (sp)+,d3
  1974.     add.l    d1,d3
  1975.     addx.l    d0,d2
  1976.     move.l    d3,-(SP)
  1977.     move.l    d2,-(SP)
  1978.     jmp    donext(PC)
  1979. *
  1980.     dcode    1+,x,dplus,plus1
  1981.     addq.l    #1,(SP)
  1982.     jmp    donext(PC)
  1983. *
  1984.     dcode    2+,x,plus1,plus2
  1985.     addq.l    #2,(SP)
  1986.     jmp    donext(PC)
  1987. *
  1988.     dcode    3+,x,plus2,plus3
  1989.     addq.l    #3,(SP)
  1990.     jmp    donext(PC)
  1991. *
  1992.     dcode    4+,x,plus3,plus4
  1993.     addq.l    #4,(SP)
  1994.     jmp    donext(PC)
  1995. *
  1996.     dcode    8+,x,plus4,plus8
  1997.     addq.l    #8,(SP)
  1998.     jmp    donext(PC)
  1999. *
  2000.     dcode    1-,x,plus8,min1
  2001.     subq.l    #1,(SP)
  2002.     jmp    donext(PC)
  2003. *
  2004.     dcode    2-,x,min1,min2
  2005.     subq.l    #2,(SP)
  2006.     jmp    donext(PC)
  2007. *
  2008.     dcode    4-,x,min2,min4
  2009.     subq.l    #4,(SP)
  2010.     jmp    donext(PC)
  2011. *
  2012.     dcode    8-,x,min4,min8
  2013.     subq.l    #8,(SP)
  2014.     jmp    donext(PC)
  2015. *
  2016.     dcode    2*,x,min8,times2
  2017.     move.l    (SP),d0
  2018.     asl.l    #1,d0
  2019.     move.l    d0,(SP)
  2020.     jmp    donext(PC)
  2021. *
  2022.     dcode    4*,x,times2,times4
  2023.     move.l    (SP),d0
  2024.     asl.l    #2,d0
  2025.     move.l    d0,(SP)
  2026.     jmp    donext(PC)
  2027. *
  2028.     dcode    2/,x,times4,xdiv2
  2029.     move.l    (SP),d0
  2030.     asr.l    #1,d0
  2031.     move.l    d0,(SP)
  2032.     jmp    donext(PC)
  2033. *
  2034. ; ^elem expects base addr on mstack, and an index on pstack
  2035.     dcode    (^ELEM),x,xdiv2,pelem    ; return address of array eleme
  2036.     move.l    d5,a2    ; pickup base address on mstack
  2037.     move.l    (a2),d7    ; base of object in d7
  2038.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2039.     clr.l    d1
  2040.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2041.     add.l    d1,d7    ; d7 points to idx hdr
  2042.     move.w    0(a3,d7.l),d1    ; fetch width word from header
  2043.     mulu    2(SP),d1    ; multiply index * width
  2044.     add.l    d1,d7    ; add to base address
  2045.     addq.l    #4,d7    ; skip the header
  2046.     move.l    d7,(SP)    ; leave on data stack
  2047.     jmp    donext(PC)
  2048. *
  2049.     dcode    IDXBASE,x,pelem,idxbas    ; idx addr of indexed object
  2050.     move.l    d5,a2    ; pickup base address on mstack
  2051.     move.l    (a2),d7    ; base of object in d7
  2052.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2053.     clr.l    d1
  2054.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2055.     add.l    d1,d7    ; d7 points to idx hdr
  2056.     addq.l    #4,d7    ; skip the idx hdr
  2057.     move.l    d7,-(SP)    ; leave the ^ixdata
  2058.     jmp    donext(PC)
  2059. *
  2060.     dcode    LIMIT,x,idxbas,limit    ; limit of indexed object
  2061.     move.l    d5,a2    ; pickup base address on mstack
  2062.     move.l    (a2),d7    ; base of object in d7
  2063.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2064.     clr.l    d1
  2065.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2066.     add.l    d1,d7    ; d7 points to idx hdr
  2067.     move.w    2(a3,d7.l),-(SP)    ; leave the limit
  2068.     clr.w    -(SP)
  2069.     jmp    donext(PC)
  2070. *
  2071.     dcode    RANGE?,x,limit,qrange    ; index out of range?
  2072.     move.l    d5,a2    ; pickup base address on mstack
  2073.     move.l    (a2),d7    ; base of object in d7
  2074.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2075.     clr.l    d1
  2076.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2077.     add.l    d1,d7    ; d7 points to idx hdr
  2078.     clr.l    d0
  2079.     move.w    2(a3,d7.l),d0    ; get the limit
  2080.     cmp.l    (SP),d0    ; is limit > index?
  2081.     sle    d1    ; true if out of range
  2082.     neg.b    d1    ; forth boolean
  2083.     move.l    d1,-(SP)
  2084.     jmp    donext(PC)
  2085. *
  2086.     dcode    AT1,x,qrange,at1    ; at opt for byte elements
  2087.     move.l    d5,a2    ; pickup base address on mstack
  2088.     move.l    (a2),d7    ; base of object in d7
  2089.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2090.     clr.l    d1
  2091.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2092.     add.l    d1,d7    ; d7 points to idx hdr
  2093.     add.l    (SP)+,d7    ; add the index
  2094.     clr.l    d0
  2095.     move.b    4(a3,d7.l),d0    ; fetch addr+4 (for idx hdr)
  2096.     move.l    d0,-(SP)
  2097.     jmp    donext(PC)
  2098. *
  2099.     dcode    AT2,x,at1,at2    ; at opt for byte elements
  2100.     move.l    d5,a2    ; pickup base address on mstack
  2101.     move.l    (a2),d7    ; base of object in d7
  2102.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2103.     clr.l    d1
  2104.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2105.     add.l    d1,d7    ; d7 points to idx hdr
  2106.     move.l    (SP),d0    ; get the index
  2107.     lsl.w    #1,d0    ; index * 2
  2108.     add.l    d0,d7    ; add the index
  2109.     move.w    4(a3,d7.l),d1    ; fetch addr+4 (for idx hdr)
  2110.     ext.l    d1    ; sign extend
  2111.     move.l    d1,(sp)
  2112.     jmp    donext(PC)
  2113. *
  2114.     dcode    AT4,x,at2,at4    ; at opt for long elements
  2115.     move.l    d5,a2    ; pickup base address on mstack
  2116.     move.l    (a2),d7    ; base of object in d7
  2117.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2118.     clr.l    d1
  2119.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2120.     add.l    d1,d7    ; d7 points to idx hdr
  2121.     move.l    (SP)+,d0    ; get the index
  2122.     lsl.w    #2,d0    ; index * 4
  2123.     add.l    d0,d7    ; add the index
  2124.     move.l    4(a3,d7.l),-(SP)    ; fetch addr+4 (for idx hdr)
  2125.     jmp    donext(PC)
  2126. *
  2127.     dcode    TO1,x,at4,to1    ; To opt for byte elements
  2128.     move.l    d5,a2    ; pickup base address on mstack
  2129.     move.l    (a2),d7    ; base of object in d7
  2130.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2131.     clr.l    d1
  2132.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2133.     add.l    d1,d7    ; d7 points to idx hdr
  2134.     add.l    (SP)+,d7    ; add the index
  2135.     move.l    (SP)+,d0
  2136.     move.b    d0,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  2137.     jmp    donext(PC)
  2138. *
  2139.     dcode    TO2,x,to1,to2    ; To opt for byte elements
  2140.     move.l    d5,a2    ; pickup base address on mstack
  2141.     move.l    (a2),d7    ; base of object in d7
  2142.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2143.     clr.l    d1
  2144.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2145.     add.l    d1,d7    ; d7 points to idx hdr
  2146.     move.l    (SP)+,d0    ; get the index
  2147.     lsl.w    #1,d0    ; index * 2
  2148.     add.l    d0,d7    ; add the index
  2149.     move.l    (sp)+,d1
  2150.     move.w    d1,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  2151.     jmp    donext(PC)
  2152. *
  2153.     dcode    TO4,x,to2,to4    ; to opt for long elements
  2154.     move.l    d5,a2    ; pickup base address on mstack
  2155.     move.l    (a2),d7    ; base of object in d7
  2156.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2157.     clr.l    d1
  2158.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2159.     add.l    d1,d7    ; d7 points to idx hdr
  2160.     move.l    (SP)+,d0    ; get the index
  2161.     lsl.w    #2,d0    ; index * 4
  2162.     add.l    d0,d7    ; add the index
  2163.     move.l    (SP)+,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  2164.     jmp    donext(PC)
  2165. *
  2166.     dcode    ++4,x,to4,inc4    ; inc opt for long elements
  2167.     move.l    d5,a2    ; pickup base address on mstack
  2168.     move.l    (a2),d7    ; base of object in d7
  2169.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2170.     clr.l    d1
  2171.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2172.     add.l    d1,d7    ; d7 points to idx hdr
  2173.     move.l    (SP)+,d0    ; get the index
  2174.     lsl.w    #2,d0    ; index * 4
  2175.     add.l    d0,d7    ; add the index
  2176.     move.l    (SP)+,d1    ; get increment
  2177.     add.l    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  2178.     jmp    donext(PC)
  2179. *
  2180.     dcode    ++2,x,inc4,inc2    ; inc opt for word elements
  2181.     move.l    d5,a2    ; pickup base address on mstack
  2182.     move.l    (a2),d7    ; base of object in d7
  2183.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2184.     clr.l    d1
  2185.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2186.     add.l    d1,d7    ; d7 points to idx hdr
  2187.     move.l    (SP)+,d0    ; get the index
  2188.     lsl.w    #1,d0    ; index * 4
  2189.     add.l    d0,d7    ; add the index
  2190.     move.l    (SP)+,d1    ; get increment
  2191.     add.w    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  2192.     jmp    donext(PC)
  2193. *
  2194.     dcode    ++1,x,inc2,inc1    ; inc opt for byte elements
  2195.     move.l    d5,a2    ; pickup base address on mstack
  2196.     move.l    (a2),d7    ; base of object in d7
  2197.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2198.     clr.l    d1
  2199.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2200.     add.l    d1,d7    ; d7 points to idx hdr
  2201.     move.l    (SP)+,d0    ; get the index
  2202.     add.l    d0,d7    ; add the index
  2203.     move.l    (SP)+,d1    ; get increment
  2204.     add.b    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  2205.     jmp    donext(PC)
  2206. *
  2207. ; fast left lshift ( val #shift -- val )
  2208.     dcode    <<,x,inc1,shfl
  2209.     popd0
  2210.     popd1
  2211.     lsl.l    d0,d1
  2212.     move.l    d1,-(SP)
  2213.     jmp    donext(PC)
  2214. *
  2215. ; fast right lshift ( val #shift -- val )
  2216.     dcode    >>,x,shfl,shfr
  2217.     popd0
  2218.     popd1
  2219.     lsr.l    d0,d1
  2220.     move.l    d1,-(SP)
  2221.     jmp    donext(PC)
  2222. *
  2223.     dcode    (ABS),x,shfr,abs_    ; leave absolute of mstack addr
  2224.     move.l    d5,a2
  2225.     move.l    (a2),d0
  2226.     add.l    a3,d0
  2227.     move.l    d0,-(SP)
  2228.     jmp    donext(PC)
  2229. *
  2230.     dcode    COUNT,x,abs_,count
  2231.     move.l    (SP),d0
  2232.     add.l    #1,(SP)
  2233.     clr.l    d1
  2234.     move.b    0(A3,d0.l),d1
  2235.     move.l    d1,-(SP)
  2236.     jmp    donext(PC)
  2237. *
  2238.     dcode    DEPTH,x,count,depth
  2239.     move.l    SP,d0
  2240.     sub.l    a3,d0
  2241.     move.l    #(s09-origin),d7
  2242.     sub.l    0(a3,d7.l),d0
  2243.     neg.l    d0
  2244.     asr.l    #2,d0
  2245.     pushD0
  2246.     jmp    donext(PC)
  2247. *
  2248.     dcode    FILL,x,depth,fil
  2249.     popD0
  2250. fill1    popD1
  2251.     move.l    (SP)+,d7
  2252.     lea    0(a3,d7.l),a0
  2253. fil1    subq.l    #1,d1
  2254.     bmi    fil2
  2255.     move.b    d0,(a0)+
  2256.     bra.s    fil1
  2257. fil2    jmp    donext(PC)
  2258. *
  2259.     dcode    ERASE,x,fil,era
  2260.     clr.l    d0
  2261.     bra.s    fill1
  2262. *
  2263.     dcode    BLANKS,x,era,blanks
  2264.     moveq    #$20,d0
  2265.     bra.s    fill1
  2266. *    
  2267.     dcode    +BASE,x,blanks,basadr
  2268.     move.l    (SP)+,d7
  2269.     pea    0(a3,d7.l)    ; push absolute address = base+pa
  2270.     jmp    donext(PC)
  2271. *
  2272.     dcode    -BASE,x,basadr,minbas
  2273.     move.l    a3,d0
  2274.     sub.l    d0,(SP)
  2275.     jmp    donext(PC)
  2276. *
  2277.     dcode    ROT,x,minbas,rot
  2278.     popD0
  2279.     popD1
  2280.     move.l    (SP),d2
  2281.     move.l    d1,(SP)
  2282.     pushD0
  2283.     move.l    d2,-(SP)
  2284.     jmp    donext(PC)
  2285. *
  2286.     dcode    PICK,x,rot,pick
  2287.     move.l    (SP),d0
  2288.     asl.l    #2,d0    ; index * 4
  2289.     move.L    0(SP,d0.w),(SP)
  2290.     jmp    donext(PC)
  2291. *
  2292.     dcode    RESET,x,pick,rset    ; reboot the machine
  2293.     reset
  2294. *
  2295.     dcode    (FDOS),x,rset,fdos    ; general file system trap call
  2296.     lea    fdtrap(PC),a0    ; stack : (pblock trap --- result)
  2297.     clr.l    d0
  2298.     move.w    (SP)+,d0    ; function selector
  2299.     move.w    (SP)+,(a0)    ; move in trap#
  2300.     movea.l    (SP)+,a0    ; file control block
  2301.     adda.l    a3,a0    ; make it absolute
  2302. fdtrap    DC.W    0    ; call Toolbox
  2303.     move.w    ioResult(a0),d0    ; leave result on stack
  2304.     ext.l    d0
  2305.     pushd0
  2306.     jmp    donext(PC)
  2307. *
  2308.     dcode    (MAKE),x,fdos,make_
  2309.     move.l    (SP)+,a0    ; parm block offset in a0
  2310.     add.l    a3,a0    ; make it absolute
  2311.     _Hcreate        ; call Toolbox
  2312.     move.w    ioResult(a0),d0    ; leave result on stack
  2313.     ext.l    d0
  2314.     pushd0
  2315.     jmp    donext(PC)
  2316. *
  2317.     dcode    (OPEN),x,make_,open_
  2318.     popd0        ; get access mode in d0
  2319.     move.l    (SP)+,a0    ; parm block offset in a0
  2320.     add.l    a3,a0    ; make it absolute
  2321.     move.b    d0,ioPermssn(a0)    ; set i/o permission
  2322.     _Hopen        ; open the file
  2323.     move.w    ioResult(a0),d0    ; leave result on stack
  2324.     ext.l    d0
  2325.     pushd0
  2326.     jmp    donext(PC)
  2327. *
  2328.     dcode    (CLOSE),x,open_,close_
  2329.     move.l    (SP)+,a0    ; parm block offset in a0
  2330.     add.l    a3,a0    ; make it absolute
  2331.     _close        ; call Toolbox CLOSE
  2332.     move.w    ioResult(a0),d0    ; leave result on stack
  2333.     ext.l    d0
  2334.     pushd0
  2335.     jmp    donext(PC)
  2336. *
  2337.     dcode    (DELETE),x,close_,delet_
  2338.     move.l    (SP)+,a0    ; parm block offset in a0
  2339.     add.l    a3,a0    ; make it absolute
  2340.     _delete        ; call Toolbox DELETE
  2341.     move.w    ioResult(a0),d0    ; leave result on stack
  2342.     ext.l    d0
  2343.     pushd0
  2344.     jmp    donext(PC)
  2345. *
  2346.     dcode    (READ),x,delet_,read_
  2347.     popD0        ; pop buffer address into d0
  2348.     add.l    a3,d0    ; make it absolute
  2349.     popD1        ; get count in d1
  2350.     move.l    (SP)+,a0    ; parm block offset in a0
  2351.     add.l    a3,a0    ; make it absolute
  2352.     move.l    d0,iobuffer(a0)    ; store buffer pointer in parm block
  2353.     move.l    d1,ioReqCount(a0)    ; store count in parm block
  2354.     _read        ; call Toolbox read
  2355.     move.w    ioResult(a0),d0    ; leave result on stack
  2356.     ext.l    d0
  2357.     pushd0
  2358.     jmp    donext(PC)
  2359. *
  2360.     dcode    (WRITE),x,read_,write_
  2361.     popD0        ; pop buffer address into d0
  2362.     add.l    a3,d0    ; make it absolute
  2363.     popD1        ; get count in d1
  2364.     move.l    (SP)+,a0    ; parm block offset in a0
  2365.     add.l    a3,a0    ; make it absolute
  2366.     move.l    d0,iobuffer(a0)    ; store buffer pointer in parm block
  2367.     move.l    d1,ioReqCount(a0)    ; store count in parm block
  2368.     _write        ; call Toolbox read
  2369.     move.w    ioResult(a0),d0    ; leave result on stack
  2370.     ext.l    d0
  2371.     pushD0
  2372.     jmp    donext(PC)
  2373. *
  2374.     dcode    (LSEEK),x,write_,lseek
  2375.     popD0        ; pickup position offset in D0
  2376.     popD1        ; pickup positioning mode in D1
  2377.     move.l    (SP)+,a0    ; pop pba
  2378.     add.l    a3,a0
  2379.     move.l    d0,ioPosOffset(a0)    ; set offset in parm block
  2380.     move.w    d1,ioPosMode(a0)    ; set mode in parm block
  2381.     _SetFPos
  2382.     move.w    ioResult(a0),d0    ; leave result on stack
  2383.     ext.l    d0
  2384.     pushd0
  2385.     jmp    donext(PC)
  2386. *
  2387. ; ------- (;CODE) is needed by the following words
  2388.     dcol    (;CODE),x,lseek,pscode
  2389.     cfas    rfrom,latest,pfa,cfa,store,semis
  2390. *
  2391. ; ------- The following words are ;CODE type words
  2392.     dcol    CONSTANT,x,pscode,const
  2393.     cfas    kreate,comma
  2394.     scode        ; points to (;CODE)
  2395. concode    addq.l    #4,d6    ; runtime code for constant
  2396.     move.l    0(a3,d6.l),-(SP)
  2397.     jmp    donext(PC)
  2398. *
  2399.     dcol    :,I,const,colon    ; this colon doesn't set Context
  2400.     cfas    qexec,stcsp    ; to Current.
  2401.     cfas    kreate,rbrak
  2402.     scode
  2403. colcode    suba.l    a3,a4    ; convert absolute address to offset
  2404.     move.l    a4,-(a6)    ; push current IP to Return stack
  2405.     addq.l    #4,d6    ; advance WP to pfa of word being def.
  2406.     lea    0(a3,d6.l),a4    ; get absolute addr in A4
  2407.     jmp    donext(PC)
  2408. *
  2409.     dcol    DOES>,x,colon,does
  2410.     cfas    rfrom,latest,pfa
  2411.     DATA    store-origin
  2412.     scode
  2413. doescode    addq.l    #4,d6
  2414.     suba.l    a3,a4
  2415.     move.l    a4,-(a6)
  2416.     move.l    0(a3,d6.l),d7
  2417.     lea    0(a3,d7.l),a4
  2418.     addq.l    #4,d6
  2419.     move.l    d6,-(SP)
  2420.     jmp    donext(PC)
  2421. *
  2422.     dcol    VARIABLE,x,does,varb
  2423.     cfas    const
  2424.     scode
  2425. varcode    addq.l    #4,d6
  2426.     move.l    d6,-(SP)
  2427.     jmp    donext(PC)
  2428. *
  2429.     dcode    OBJMP,x,varb,objmp
  2430.     move.l    #(obcode-origin),d0    ; get addr of object code
  2431.     jmp    0(a3,d0.l)    ; obj puts its addr on stack
  2432. *
  2433.     dcol    (AB"),x,objmp,abq_    ; abort" runtime word
  2434.     cfas    mindup
  2435.     eif.    abq11
  2436.     cfas    cr,lit,10+origin,beep,here,count,type
  2437.     cfas    lit,63+origin,emit,space,R,count,type,abort
  2438.     else.    abq11
  2439.     cfas    rfrom,count,plus,aline,tor
  2440.     ethen.    abq11
  2441.     cfas    semis
  2442. *
  2443.     dcol    PREFIX,x,abq_,prefix    ; prefix builder for mcfa
  2444.     cfas    builds,times4,wcomma,immed
  2445.     cfas    does
  2446. dopref    cfas    fetpfa
  2447.     cfas    cfa,over,wfetch,plus
  2448.     cfas    swap_,min4,over,fetch,lit,6+origin,subt
  2449.     cfas    fetch,subt,abq_
  2450.     STR    "invalid prefix "
  2451.     cfas    state
  2452.     if.    pre11
  2453.     cfas    comma,semis
  2454.     then.    pre11
  2455.     cfas    exec,semis
  2456. *
  2457. ; execute 1cfa of object vector ivar
  2458.     dcode    X1CFA,x,prefix,x1cfa
  2459.     move.l    d5,a2    ; 1cfa is the fetch/deferred exec routine
  2460.     clr.l    d6
  2461.     move.w    (a4)+,d6    ; get offset to ivar
  2462.     add.l    (a2),d6    ; add base addr to get 1cfa addr in WP
  2463.     move.l    0(a3,d6.l),d7    ; get code addr in d7
  2464.     jmp    0(a3,d7.l)
  2465. *
  2466.     dcol    VOCABULARY,x,x1cfa,vocab
  2467.     cfas    builds
  2468.     mlit    $8120
  2469.     cfas    wcomma,currnt,min2,comma,here,vocl,comma
  2470.     cfas    vocl2,does
  2471. dovocab    cfas    plus2,contxt2,semis
  2472. *
  2473. ; define prefixes for 3cfa variables,vects
  2474.     ddoes    PUT,I,vocab,preput,dopref    ; 2cfa for all
  2475.     DC.W    8
  2476.     ddoes    PUTDEF,I,preput,prputd,dopref    ; 1cfa for sysVe
  2477.     DC.W    4
  2478. ; define code handlers for 3cfa variables,vects
  2479.     DATA    0    ; fetch code for sysvect
  2480.     DC.W    8    ; len to vect's pfa from 1cfa
  2481. dofetchv    addq.l    #8,d6    ; advance wp to pfa
  2482.     move.l    0(a3,d6.l),-(SP)    ; get contents of pfa
  2483.     jmp    donext(PC)
  2484. *
  2485.     DATA    preput+4-origin    ; store code
  2486.     DC.W    4    ; len to vect's pfa from 1cfa
  2487. dostore    addq.l    #4,d6    ; advance wp to pfa
  2488.     move.l    (SP)+,0(a3,d6.l)    ; get contents of pfa
  2489.     jmp    donext(PC)
  2490. *
  2491.     DATA    0    ; increment code
  2492.     DC.W    8    ; len to vect's pfa from 1cfa
  2493. doincr    addq.l    #8,d6    ; advance wp to pfa
  2494.     popd0
  2495.     add.l    d0,0(a3,d6.l)    ; increment contents of pfa
  2496.     jmp    donext(PC)
  2497. *
  2498.     DC.W    12
  2499. doexec    add.l    #12,d6
  2500.     move.l    0(a3,d6.l),d6    ; get address to execute
  2501.     move.l    0(a3,d6.l),d7    ; get contents of CFA
  2502.     jmp    0(a3,d7.l)    ; execute the code
  2503.     DC.W    12    ; execute a system vector table entry
  2504. dosexec    add.l    #12,d6
  2505.     move.l    userdp(PC),d0    ; rel base of system vector table
  2506.     add.l    0(a3,d6.l),d0    ; add offset into table
  2507.     move.l    0(a3,d0.l),d1    ; get vector contents
  2508.     beq    dodeflt    ; if 0, exec default
  2509.     move.l    d1,d6
  2510.     bra.s    sexec
  2511. dodeflt    move.l    4(a3,d6.l),d6    ; get default cfa to execute
  2512. sexec    move.l    0(a3,d6.l),d7    ; get contents of CFA
  2513.     jmp    0(a3,d7.l)    ; execute the code
  2514. *
  2515.     DATA    prputd+4-origin
  2516.     DC.W    8    ; set offset, default for system vector
  2517. doputdef    addq.l    #8,d6
  2518.     move.l    (SP)+,0(a3,d6.l)    ; set the offset
  2519.     move.l    (SP)+,4(a3,d6.l)    ; set the default
  2520.     jmp    donext(PC)
  2521. *
  2522.     DATA    preput+4-origin
  2523.     DC.W    4    ; set sys vector table entry for this vect
  2524. doputsv    addq.l    #4,d6
  2525.     move.l    userdp(PC),d0
  2526.     add.l    0(a3,d6.l),d0    ; add the offset
  2527.     move.l    (SP)+,0(a3,d0.l)    ; store the vector
  2528.     jmp    donext(PC)
  2529. *
  2530.     DC.W    12    ; len to value's pfa from 1cfa
  2531. dofetch    add.l    #12,d6    ; advance wp to pfa
  2532.     move.l    0(a3,d6.l),-(SP)    ; get contents of pfa
  2533.     jmp    donext(PC)
  2534. *
  2535.     dcol    ",",x,prputd,comma    ; begin comman dict entry
  2536.     cfas    here,store,pfour,allot,semis
  2537. *
  2538.     dcol    "W,",x,comma,wcomma    ; begin Wcomma dict entry
  2539.     cfas    here,wstore,lit,2+origin,allot,semis
  2540. *
  2541.     dcol    "C,",x,wcomma,ccomma    ; begin C, dict entry
  2542.     cfas    here,cstore,pone,allot,semis
  2543. *
  2544.     dcol    @PFA,x,ccomma,fetpfa
  2545.     cfas    mfind,zequ,abq_
  2546.     STR    "not found  "
  2547.     cfas    drop,semis
  2548. *
  2549.     dcol    LFA,x,fetpfa,lfa
  2550.     mlit    8
  2551.     cfas    subt,semis
  2552. *
  2553.     dcol    NFA,x,lfa,nfa
  2554.     mlit    9
  2555.     cfas    subt
  2556.     mlit    -1
  2557.     cfas    traver,semis
  2558. *
  2559.     dcol    PFA,x,nfa,pfa
  2560.     mlit    1
  2561.     cfas    traver,lit,9+origin,plus,semis
  2562. *
  2563.     dcol    ALIGN,x,pfa,aline
  2564.     cfas    dup
  2565.     mlit    1
  2566.     cfas    and_,plus,semis
  2567. *
  2568.     dcol    DECIMAL,x,aline,decim
  2569.     mlit    $0a
  2570.     cfas    base2,semis
  2571. *
  2572.     dcol    HEX,x,decim,hex
  2573.     mlit    $10
  2574.     cfas    base2,semis
  2575. *
  2576.     dcol    (."),x,hex,dotq_
  2577.     cfas    r,count,dup,plus1,aline,rfrom,plus,toR,type
  2578.     cfas    semis
  2579. *
  2580.     dcol    PAD,x,dotq_,pad
  2581.     mlit    padbuf-origin
  2582.     cfas    semis
  2583. *
  2584.     dcol    #>,x,pad,enum
  2585.     cfas    drop2,hld,pad,over,subt,semis
  2586. *
  2587.     dcol    HOLD,x,enum,hold
  2588.     DATA    pmone-origin
  2589.     cfas    hld1,hld,cstore,semis
  2590. *
  2591.     dcol    SIGN,x,hold,sign
  2592.     cfas    rot,zless
  2593.     if.    Z3
  2594.     mlit    $2d
  2595.     cfas    hold
  2596.     then.    Z3
  2597.     cfas    semis
  2598. *
  2599.     dcol    #,x,sign,sharp
  2600.     cfas    base,msmod,rot
  2601.     mlit    9
  2602.     cfas    over,less
  2603.     if.    Z4
  2604.     mlit    7
  2605.     cfas    plus
  2606.     then.    Z4
  2607.     mlit    $30
  2608.     cfas    plus,hold,semis
  2609. *
  2610.     dcol    #S,x,sharp,sharps
  2611.     begin.    Z5
  2612.     cfas    sharp,dup2,or_,zequ
  2613.     until.    Z5
  2614.     cfas    semis
  2615. *
  2616.     dcol    <#,x,sharps,snum
  2617.     cfas    pad,hld2,semis
  2618. *
  2619.     dcol    D.R,x,snum,ddotr
  2620.     cfas    toR,swap_,over,dabs,snum,sharps,sign,enum,rfrom
  2621.     cfas    over,subt,spaces,type,semis
  2622. *
  2623.     dcol    D.,x,ddotr,ddot
  2624.     mlit    0
  2625.     cfas    ddotr,space,semis
  2626. *
  2627.     dcol    .,x,ddot,dot
  2628.     cfas    sToD,ddot,semis
  2629. *
  2630.     dcol    U.,x,dot,udot
  2631.     mlit    0
  2632.     cfas    ddot,semis
  2633. *
  2634.     dcol    .R,x,udot,dotR
  2635.     cfas    toR,sToD,rfrom,ddotr,semis
  2636. *
  2637.     dcol    ?,x,dotR,quest
  2638.     cfas    fetch,dot,semis
  2639. *
  2640.     dcol    SPACE,x,quest,space
  2641.     cfas    bl,emit,semis
  2642. *
  2643.     dcol    SPACES,x,space,spaces
  2644.     mlit    0
  2645.     do.    Z7
  2646.     cfas    bl,emit
  2647.     loop.    Z7
  2648.     cfas    semis
  2649. *
  2650.     dcol    -TRAILING,x,spaces,mtrail
  2651.     cfas    dup
  2652.     mlit    0
  2653.     do.    Z8
  2654.     cfas    over,over,plus,min1,cfetch,bl,subt
  2655.     eif.    Z10
  2656.     cfas    leave
  2657.     else.    Z10
  2658.     cfas    min1
  2659.     ethen.    Z10
  2660.     loop.    Z8
  2661.     cfas    semis
  2662. *
  2663.     dcol    N>COUNT,x,mtrail,ncount
  2664.     cfas    count
  2665.     mlit    $1f
  2666.     cfas    and_,semis
  2667. *
  2668.     dcol    ID.,x,ncount,iddot
  2669.     cfas    ncount,type,space,semis
  2670. *
  2671.     dcol    EMIT,x,iddot,emit
  2672.     cfas    dup,emitvec,pemitv,pone     ; send the char via Quickdraw
  2673.     cfas    out1,semis
  2674. *
  2675.     dcol    TYPE,x,emit,type
  2676.     cfas    dup,out1,dup2,typevec,ptypev,semis
  2677.     dcol    CR,x,type,cr
  2678.     cfas    crvec,pcrvec,semis
  2679. *
  2680.     dcol    CONTBOT,x,cr,contbot
  2681.     cfas    port_,lit,windowsize+origin,plus,plus4
  2682.     cfas    wfetch,semis
  2683. *
  2684.     dcol    CONTTOP,x,contbot,conttop
  2685.     cfas    port_,lit,windowsize+origin,plus
  2686.     cfas    wfetch,semis
  2687. *
  2688.     dcol    ?LEAD,x,conttop,qlead    ; return proper leading for fo
  2689.     cfas    port_,lit,txsize+origin,plus,wfetch
  2690.     cfas    lit,120+origin,star,lit,50+origin,plus    ; Increase 120 f
  2691.     cfas    lit,100+origin,slash,semis
  2692. *
  2693.     dcol    ?LINES,x,qlead,qlines    ; number of even lines in port
  2694.     cfas    qlead,contbot,conttop    ; bottom-top of content rgn
  2695.     cfas    subt,over,plus1,subt    ; minus ?LEAD+1
  2696.     cfas    swap_,slash,semis    ; divided by ?LEAD
  2697. *
  2698.     dcol    BOTTOM,x,qlines,scrbot    ; coordinate of screen bottom
  2699.     cfas    conttop,plus4,qlead,qlines,star,plus
  2700.     cfas    semis
  2701. *
  2702.     dcol    (CR),x,scrbot,cr_    ; simulate a CR in Quickdraw
  2703.     cfas    dotcur,fetxy,swap_,drop,lit,8+origin,swap_
  2704.     cfas    dup,scrbot,grt
  2705.     eif.    x27
  2706.     cfas    pzer,qlead,minus,scroll,gotoxy
  2707.     else.    x27
  2708.     cfas    qlead,plus
  2709.     cfas    gotoxy
  2710.     ethen.    x27
  2711.     cfas    dotcur,semis
  2712. *
  2713.     dcol    (BS),x,cr_,bs_
  2714.     cfas    dotcur,fetxy,swap_,lit,6+origin,subt,lit,8+origin,max
  2715.     cfas    swap_,dup2,gotoxy,bl,emit,gotoxy,dotcur,semis
  2716. *
  2717.     dcol    ?TERMINAL,x,bs_,qterm
  2718.     cfas    lit,$28+origin,qevt,semis
  2719.     dcol    (KEY),x,qterm,key_
  2720.     mlit    $2A        ; kbd and mouse events
  2721.     cfas    getevt,lit,2+origin,grt
  2722.     eif.    Z100
  2723.     cfas    ftemsg,lit,$00ff+origin,and_
  2724.     else.    Z100
  2725.     cfas    pmone
  2726.     ethen.    Z100
  2727.     cfas    semis
  2728. *
  2729.     dcol    (DKEY),x,key_,dkey_
  2730.     cfas    ufcb,pone,lit,ftwork    ; read 1 char from disk
  2731.     cfas    read_,dup,dkerr2
  2732.     eif.    y10
  2733.     cfas    keystor,pone,curs_2    ; restore to terminal if err
  2734.     cfas    lit,13+origin
  2735.     else.    y10
  2736.     cfas    lit,ftwork,cfetch    ; leav char on stack
  2737.     ethen.    y10
  2738.     cfas    qpause,semis
  2739. *
  2740.     dcol    KEY!,x,dkey_,keystor    ; reset KEY to keyboard
  2741.     cfas    lit,key_,keyvec2,semis
  2742. *
  2743.     dcol    KEY,x,keystor,key
  2744.     cfas    keyvec,semis    ; vectored key
  2745. *
  2746.     dcol    <",x,key,diskin    ; set to disk key inpu
  2747.     cfas    ufcb,close_,dot    ; close the oldfile
  2748.     cfas    lit,useFcb,lit,80+origin,era,pzer,curs_2
  2749.     cfas    lit,34+origin,word,here,dup,cfetch,plus1
  2750.     cfas    lit,useFname,swap_,cmove
  2751.     cfas    lit,useFname,basadr,lit,useFcb,sflptr
  2752.     cfas    ufcb,pone,open_,dot
  2753.     cfas    cr,lit,dkey_,keyvec2,semis
  2754. *
  2755. ; ------------ Disk words for FORTH screen handling
  2756.     dcol    !FPTR,x,diskin,sflptr    ; ( ^fname pblock -- )
  2757.     cfas    lit,18+origin,plus,store,semis
  2758. *
  2759.     dcol    ?COMP,x,sflptr,qcomp
  2760.     cfas    state,zequ,abq_
  2761.     STR    "compilation only "
  2762.     cfas    semis
  2763. *
  2764.     dcol    ?DP,x,qcomp,qdp    ; dp grown into heap?
  2765.     cfas    room,pone,less,abq_
  2766.     STR    " out of room "
  2767.     cfas    semis
  2768. *
  2769.     dcol    ?STACK,x,qdp,qstack
  2770.     cfas    spfet,s0,swap_,uless
  2771.     cfas    abq_
  2772.     STR    "empty stack  "
  2773.     cfas    semis
  2774. *
  2775.     dcol    ?EXEC,x,qstack,qexec
  2776.     cfas    state,cstate,or_,abq_    ; err if class or forth compile
  2777.     STR    "run state only "
  2778.     cfas    semis
  2779. *
  2780.     dcol    ?PAIRS,x,qexec,qpairs
  2781.     cfas    subt,abq_
  2782.     STR    "unpaired conditionals  "
  2783.     cfas    semis
  2784. *
  2785.     dcol    ?DECIMAL,x,qpairs,qdec
  2786.     cfas    base,lit,$0a+origin,subt,abq_
  2787.     STR    "must be decimal"
  2788.     cfas    semis
  2789. *
  2790.     dcol    ?CSP,x,qdec,qcsp
  2791.     cfas    spfet,csp,subt,abq_
  2792.     STR    "definition not finished  "
  2793.     cfas    semis
  2794. *
  2795.     dcol    (NUMBER),x,qcsp,num_
  2796.     begin.    Z27
  2797.     cfas    plus1,dup,tor,cfetch,base,digit
  2798.     while.    Z27
  2799.     cfas    swap_,base,ustar,drop,rot,base
  2800.     cfas    ustar,dplus,dpl,plus1
  2801.     if.    Z28
  2802.     cfas    pone,dpl1
  2803.     then.    Z28
  2804.     cfas    rfrom
  2805.     repeat.    Z27
  2806.     cfas    rfrom,semis
  2807. *
  2808.     dcol    ?NUM,x,num_,qnum    ; ( addr -- d t OR f )
  2809.     mlit    0
  2810.     mlit    0
  2811.     cfas    rot,dup,plus1,cfetch
  2812.     mlit    $2d
  2813.     cfas    equals,dup,tor,plus
  2814.     mlit    -1
  2815.     begin.    Z30
  2816.     cfas    dpl2,num_,dup,cfetch,bl,subt
  2817.     while.    Z30
  2818.     cfas    dup,cfetch,lit,$2e+origin,subt
  2819.     if.    zz177
  2820.     cfas    rfrom,drop,drop,drop2,pzer,semis
  2821.     then.    zz177
  2822.     mlit    0
  2823.     repeat.    Z30
  2824.     cfas    drop,rfrom
  2825.     if.    Z31
  2826.     cfas    dminus
  2827.     then.    Z31
  2828.     cfas    pone,semis
  2829. *
  2830.     dcol    NUMBER,x,qnum,number    ; ( addr -- d )
  2831.     cfas    qnum,zequ,abq_
  2832.     STR    "not found  "
  2833.     cfas    semis
  2834. *
  2835.     dcol    LITERAL,I,number,liter
  2836.     cfas    state
  2837.     if.    Z32
  2838.     cfas    dup,lit
  2839.     DATA    $10000
  2840.     cfas    less,over,zless,zequ,and_
  2841.     eif.    zz39
  2842.     cfas    comp,wlit,wcomma
  2843.     else.    zz39
  2844.     cfas    comp,lit,comma    ; builds word lit if n>=0 and n<$10000
  2845.     ethen.    zz39
  2846.     then.    Z32
  2847.     cfas    semis
  2848. *
  2849.     dcol    EXPECT,x,liter,expect
  2850.     cfas    over,plus,over
  2851.     do.    Z33
  2852.     cfas    key,dup,lit,8+origin,equals    ; bs ?
  2853.     eif.    Z34
  2854.     cfas    drop,dup,i,equals,dup,rfrom,min2,plus,tor
  2855.     eif.    Z35
  2856.     cfas    lit,10+origin,beep
  2857.     else.    Z35
  2858.     cfas    bs_
  2859.     ethen.    Z35
  2860.     cfas    pzer
  2861.     else.    Z34
  2862.     cfas    dup,zequ
  2863.     if.    y118
  2864.     cfas    drop,lit,32+origin    ; map null to space
  2865.     then.    y118
  2866.     cfas    dup,lit,$0d+origin,equals
  2867.     eif.    Z36
  2868.     cfas    leave,drop,pzer,pzer,cr
  2869.     else.    Z36
  2870.     cfas    dup
  2871.     ethen.    Z36
  2872.     cfas    r,cstore,pzer,r,plus1,cstore
  2873.     ethen.    Z34
  2874.     cfas    echovec
  2875.     loop.    Z33
  2876.     cfas    drop,semis
  2877. *
  2878.     dcol    WORD,x,expect,word
  2879.     cfas    tib
  2880.     cfas    in,plus,swap_,enclos
  2881.     cfas    word_,semis
  2882. *
  2883.     dcol    WORD",x,word,wordq    ; lower-case version of word
  2884.     cfas    tib,in,plus,lit,34+origin,enclos
  2885.     cfas    lcword,here,semis
  2886.     dcol    FIND,x,wordq,mfind
  2887.     cfas    bl,word,ufind,dup,zequ
  2888.     if.    w72
  2889.     cfas    drop,here,contxt,fetch
  2890.     cfas    find_,dup,zequ
  2891.     if.    Z38
  2892.     cfas    contxt,currnt,subt
  2893.     if.    Z40
  2894.     cfas    drop,here,latest,find_
  2895.     then.    Z40
  2896.     then.    Z38
  2897.     then.    w72
  2898.     cfas    semis
  2899. *
  2900.     ADJST        ; X - null word
  2901. lkx    DC.B    $C1
  2902.     DC.B    $00
  2903.     DATA    lkmfind-origin
  2904.     DATA    colcode-origin    ; not Fig standard -
  2905.     cfas    rfrom,drop    ; note: doesn't support Forth screens
  2906.     cfas    semis
  2907. *
  2908.     dcol    "S,",x,x,scomma    ; begin S, dict entry
  2909.     cfas    here,dup,cfetch,plus1,aline
  2910.     cfas    allot,dup,rot,toggle,semis
  2911. *
  2912.     dcol    (CREATE),x,scomma,creat_
  2913.     cfas    here,pone,and_
  2914.     if.    Z410
  2915.     cfas    pzer,ccomma
  2916.     then.    Z410
  2917.     cfas    mfind
  2918.     if.    Z420
  2919.     cfas    drop,nfa,iddot,dotq_
  2920.     STR    "is redefined "
  2921.     cfas    cr
  2922.     then.    Z420
  2923.     cfas    lit,$80+origin,scomma
  2924.     cfas    latest,comma,currnt
  2925.     cfas    store,here,plus4,comma,semis
  2926. *
  2927.     dcol    (INTRP),x,creat_,intrp_
  2928.     begin.    Z43
  2929.     cfas    mfind
  2930.     eif.    Z44
  2931.     cfas    state,less
  2932.     eif.    Z45
  2933.     cfas    cfa,comma
  2934.     else.    Z45
  2935.     cfas    cfa,exec
  2936.     ethen.    Z45
  2937.     else.    Z44
  2938.     cfas    here,number,dpl,plus1
  2939.     eif.    Z46
  2940.     cfas    dliter
  2941.     else.    Z46
  2942.     cfas    drop,liter
  2943.     ethen.    Z46
  2944.     ethen.    Z44
  2945.     cfas    qdp,qstack
  2946.     again.    Z43
  2947.     cfas    semis
  2948. *
  2949.     dcol    !CSP,x,intrp_,stcsp
  2950.     cfas    spfet,csp2,semis
  2951. *
  2952.     dcol    QUERY,x,stcsp,query
  2953.     cfas    tib,lit,$99+origin
  2954.     cfas    expvec,pzer,in2,semis
  2955.     dcol    <[,I,query,lbrak
  2956.     mlit    0
  2957.     cfas    state2,semis
  2958.     dcol    ]>,x,lbrak,rbrak
  2959.     mlit    $c0
  2960.     cfas    state2,semis
  2961. *
  2962.     dcol    DEFINITIONS,x,rbrak,defs
  2963.     cfas    contxt,currnt2,semis
  2964. *
  2965.     dcol    <BUILDS,x,defs,builds
  2966.     mlit    0
  2967.     cfas    const,semis
  2968. *
  2969.     dcol    OK,x,builds,ok
  2970.     cfas    depth,ptwo,dotr,base,dup
  2971.     cfas    lit,10+origin,equals
  2972.     eif.    xx11
  2973.     cfas    lit,45+origin,emit
  2974.     else.    xx11
  2975.     cfas    dup,lit,16+origin,equals
  2976.     eif.    xx12
  2977.     cfas    lit,36+origin,emit
  2978.     else.    xx12
  2979.     cfas    lit,63+origin,emit
  2980.     ethen.    xx12
  2981.     ethen.    xx11
  2982.     cfas    drop,lit,62+origin,emit
  2983.     cfas    semis
  2984. *
  2985.     dcode    Q,x,ok,q_
  2986.     clr.w    -(sp)
  2987.     _hilitemenu
  2988.     jmp    donext(PC)
  2989. *
  2990.     dcol    QUIT,x,ok,quit
  2991.     cfas    pzer,in2
  2992.     cfas    lbrak,quvec,q_
  2993.     cfas    cr,ok
  2994.     begin.    Z48
  2995.     cfas    qdp,rpstor,query,interp,state,zequ
  2996.     if.    Z50
  2997.     cfas    ok
  2998.     then.    Z50
  2999.     again.    Z48
  3000.     cfas    semis
  3001. *
  3002.     dcol    BACK,x,quit,back
  3003.     cfas    here,subt,comma,semis
  3004. *
  3005.     dcol    FWD,x,back,fwd    ; fill in fwd branch
  3006.     cfas    here,over,subt,swap_,store,semis
  3007. *
  3008.     dcol    BEGIN,I,fwd,begin
  3009.     cfas    qcomp,here,pone,semis
  3010. *
  3011.     dcol    THEN,I,begin,then
  3012.     cfas    qcomp,lit,2+origin,qpairs,fwd,semis
  3013. *
  3014.     dcol    DO,I,then,do    ; compiles fwd branch for smart exit
  3015.     cfas    comp,do_,here,pzer,comma,lit,3+origin,semis
  3016. *
  3017.     dcol    LOOP,I,do,loop
  3018.     cfas    lit,3+origin,qpairs,comp,loop_,dup,plus4,back
  3019.     cfas    fwd,semis
  3020. *
  3021.     dcol    +LOOP,I,loop,ploop
  3022.     cfas    lit,3+origin,qpairs,comp,ploop_,dup,plus4,back
  3023.     cfas    fwd,semis
  3024. *
  3025.     dcol    COMPILE,x,ploop,comp
  3026.     cfas    qcomp,rfrom,dup,plus4
  3027.     cfas    tor,fetch,comma,semis
  3028.     dcol    [COMPILE],I,comp,bcomp
  3029.     cfas    fetpfa,cfa,comma,semis
  3030. *
  3031.     dcol    DLITERAL,I,bcomp,dliter
  3032.     cfas    state
  3033.     if.    Z51
  3034.     cfas    swap_,liter,liter
  3035.     then.    Z51
  3036.     cfas    semis
  3037. *
  3038.     dcol    UNTIL,I,dliter,until
  3039.     cfas    pone,qpairs,comp,bran0,back,semis
  3040. *
  3041.     dcol    AGAIN,I,until,again
  3042.     cfas    pone,qpairs,comp,bran,back,semis
  3043. *
  3044.     dcol    REPEAT,I,again,repeat
  3045.     cfas    tor,tor,again,rfrom,rfrom,min2
  3046.     cfas    then,semis
  3047.     dcol    IF,I,repeat,xif
  3048.     cfas    comp,bran0,here,pzer,comma,lit,2+origin,semis
  3049. *
  3050.     dcol    ELSE,I,xif,xelse
  3051.     cfas    lit,2+origin,qpairs,comp,bran,here,pzer,comma
  3052.     cfas    swap_,lit,2+origin,then,lit,2+origin,semis
  3053. *
  3054.     dcol    WHILE,I,xelse,while
  3055.     cfas    xif,plus2,semis
  3056. *
  3057.     dcol    EXIT,I,while,exit
  3058.     cfas    latest,pfa,cfa,fetch    ; is this a pcolon def?
  3059.     cfas    lit,pcolcode,equals
  3060.     eif.    se10
  3061.     cfas    comp,semip    ; yes, put in parm denester
  3062.     else.    se10
  3063.     cfas    comp,semis
  3064.     ethen.    se10
  3065.     cfas    semis
  3066. *
  3067.     dcol    ;,I,exit,semi    ; immediate - semicolon def
  3068.     cfas    qcsp,exit,lbrak,semis
  3069. *
  3070.     dcol    .",I,semi,dotq
  3071.     cfas    state
  3072.     eif.    Z52
  3073.     cfas    comp,dotq_
  3074.     cfas    wordq    ; lower-case word
  3075.     cfas    cfetch,plus1,aline,allot
  3076.     else.    Z52
  3077.     cfas    wordq,count,type
  3078.     ethen.    Z52
  3079.     cfas    semis
  3080. *
  3081.     dcol    IMMEDIATE,x,dotq,immed
  3082.     cfas    latest,lit,$40+origin,toggle,semis
  3083. *
  3084.     dcol    LATEST,x,immed,latest
  3085.     cfas    currnt,fetch,semis
  3086.     dcol    (,I,latest,lparen
  3087.     cfas    lit,$29+origin,word,semis
  3088. *
  3089.     ADJST    
  3090. lktick    DC.B    $c1    ; tick
  3091.     DC.B    $27
  3092.     DATA    lklparen-origin
  3093. tick    DATA    colcode-origin
  3094.     cfas    fetpfa,liter,semis
  3095. *
  3096.     dcol    FORGET,x,tick,forget
  3097.     cfas    defs    ; set current to context
  3098.     cfas    tick,dup,fence,uless,abq_
  3099.     STR    "in protected dictionary  "
  3100.     cfas    dup,nfa,dp2,lfa,fetch,currnt
  3101.     cfas    store,semis
  3102. *
  3103.     dcol    ROOM,x,forget,room    ; leave dict space left
  3104.     cfas    msiz,fetch,dp,bdp,fetch
  3105.     cfas    subt,subt,semis
  3106. *
  3107.     dcol    GREET,x,room,greet
  3108.     cfas    cls
  3109.     mlit    hello-origin
  3110.     cfas    count,type,cr
  3111.     mlit    bytesleft-origin
  3112.     cfas    count,type
  3113.     cfas    room,dot,cr,semis
  3114. *
  3115.     dcol    COLD,x,greet,xcold
  3116.     cfas    lit,aregn,fetch,zequ
  3117.     if.    w59
  3118.     cfas    intool    ; only if we haven't gotten heap already
  3119.     then.    w59
  3120.     cfas    lit,inits0,fetch,s02,lit,initr0,fetch,r02
  3121.     cfas    lit,initfenc,fetch,fence2,lit,initvocl,fetch,vocl2
  3122.     cfas    lit,initdp,fetch,dp2,lit,initmp,fetch,m02
  3123.     cfas    lit,initlast,fetch,lit,forth_
  3124.     cfas    lit,$0a+origin,plus,store,decim,spstor,mpstor
  3125.     cfas    forth_,defs,pzer,warn2,objini,greet,quit,semis
  3126. *
  3127.     dcol    .PAUSE,x,xcold,dpause
  3128.     cfas    lit,pausemsg,count,type,semis
  3129. *
  3130.     dcol    ?PAUSE,x,dpause,qpause    ; check if user wants to stop
  3131.     cfas    qterm
  3132.     if.    w43
  3133.     cfas    key_,drop,cr,dpause
  3134.     cfas    key_,cr,lit,0+origin,out2,lit,32+origin,grt
  3135.     if.    w44
  3136.     cfas    abort
  3137.     then.    w44
  3138.     then.    w43
  3139.     cfas    semis
  3140. *
  3141.     dcol    ABORT,x,qpause,abort
  3142.     cfas    cr
  3143.     cfas    spstor,mpstor,lit,key_,keyvec2,decim
  3144.     cfas    pone,curs_2,qstack,lbrak,forth_
  3145.     cfas    defs,abvec
  3146.     cfas    lit,$a850+origin,trap_    ; initCursor
  3147.     cfas    quit,semis
  3148. *
  3149.     ddoes    YERK,x,abort,forth_,dovocab    ; FORTH vocabulary
  3150.     DC.W    $8120
  3151. vlf    DATA    lastdef-origin
  3152.     DATA    0
  3153. *
  3154.     dcol    .VAL,x,forth_,dotval
  3155.     cfas    dotr,lit,2+origin,spaces,semis
  3156. *
  3157.     dcol    ?CFA,x,dotval,qcfa
  3158.     cfas    dup,plus4,nfa,ncount
  3159.     cfas    tor,r,plus,plus4,aline
  3160.     cfas    over,equals,rfrom,land_,semis
  3161. *
  3162.     dcol    (.STACK),x,qcfa,dstak_
  3163.     cfas    base,lit,ftwork1,store,dup2,grt    ; preserve current base
  3164.     eif.    z61
  3165.     do.    z62
  3166.     cfas    cr,ifetch,dup,decim
  3167.     cfas    lit,8+origin,dotval,dup,hex,lit,36+origin,emit
  3168.     cfas    pzer,lit,6+origin,ddotr
  3169.     cfas    lit,3+origin,spaces,aline,min4,plus1,false
  3170.     eif.    z63
  3171.     cfas    plus4,nfa,iddot
  3172.     else.    z63
  3173.     cfas    drop
  3174.     ethen.    z63
  3175.     cfas    pfour
  3176.     ploop.    z62
  3177.     else.    z61
  3178.     cfas    lit,emptymsg,count,type,less
  3179.     cfas    abq_
  3180.     STR    "Stack Underflow  "
  3181.     ethen.    z61
  3182.     cfas    lit,ftwork1,fetch,base2,cr    restore base
  3183.     cfas    semis
  3184. *
  3185. Lastdef    dcol    .S,x,dstak_,dots
  3186.     cfas    spfet,s0,swap_,lit,dsmsg
  3187.     cfas    count,type,dstak_,r0,rpfet,lit,rsmsg
  3188.     cfas    count,type,dstak_,m0,mpfet,lit,msmsg
  3189.     cfas    count,type,dstak_
  3190.     cfas    semis
  3191. *
  3192. nextdef    EQU    *
  3193.     ENDR
  3194. *
  3195.     SEG    0,32,VAR.LEN,$20
  3196. SEG0
  3197. SEG_1    JP    origin,1
  3198. END_1
  3199. END0
  3200.     ENDR
  3201. *
  3202. *    END
  3203.     RSRC    YERK,0
  3204.     STR    "Yerk Version 3.3"
  3205.     ENDR
  3206. *
  3207.     RSRC    FREF,128,32
  3208.     ASC    'APPL'
  3209.     DATA    /0
  3210.     STR    ""
  3211.     ENDR
  3212. *
  3213.     RSRC    FREF,129,32
  3214.     ASC    'COM '
  3215.     DATA    /1
  3216.     STR    ""
  3217.     ENDR
  3218. *
  3219.     RSRC    FREF,130,32
  3220.     ASC 'USER'
  3221.     DATA /2
  3222.     STR    ""
  3223.     ENDR
  3224. *
  3225.     RSRC    FREF,131,32
  3226.     ASC    'BIN '
  3227.     DATA /3
  3228.     STR    ""
  3229.     ENDR
  3230. *
  3231.     RSRC    FREF,132,32
  3232.     ASC    'TEXT'
  3233.     DATA /4
  3234.     STR    ""
  3235.     ENDR
  3236. *
  3237.     RSRC    ICN#,128,32
  3238.     HEX    71c0.0000.cb20.0000
  3239.     HEX    c620.0000.6040.0000
  3240.     HEX    3080.0000.1900.1f80
  3241.     HEX    1900.2040.197e.4020
  3242.     HEX    1981.9810.1e8e.e408
  3243.     HEX    0ccf.3f87.3069.1803
  3244.     HEX    c864.8003.c864.4003
  3245.     HEX    c8c8.f003.c99f.8ff3
  3246.     HEX    c981.990f.c9ff.9903
  3247.     HEX    c8fd.8200.c801.8400
  3248.     HEX    c801.8200.c801.91ce
  3249.     HEX    c801.9939.c801.9f32
  3250.     HEX    c801.d724.c800.e308
  3251.     HEX    c800.0304.cfff.e322
  3252.     HEX    c000.1331.c000.1339
  3253.     HEX    ffff.e3ef.7fff.c1c6
  3254. *
  3255.     HEX    71c0.0000.fbe0.0000
  3256.     HEX    ffe0.0000.7fc0.0000
  3257.     HEX    3f80.0000.1f00.1f80
  3258.     HEX    1f00.3fc0.1f7e.7fe0
  3259.     HEX    1fff.fff0.1ffe.e7f8
  3260.     HEX    0fff.ffff.3ff9.ffff
  3261.     HEX    fffc.ffff.fffc.7fff
  3262.     HEX    fff8.ffff.ffff.ffff
  3263.     HEX    ffff.ff0f.ffff.ff03
  3264.     HEX    ffff.fe00.ffff.fc00
  3265.     HEX    ffff.fe00.ffff.ffce
  3266.     HEX    ffff.ffff.ffff.fffe
  3267.     HEX    ffff.fffc.ffff.fff8
  3268.     HEX    ffff.fffc.ffff.fffe
  3269.     HEX    ffff.ffff.ffff.c1ff
  3270.     HEX    ffff.c1ef.7fff.c1c6
  3271.     ENDR
  3272. *
  3273.     RSRC    ICN#,129,32
  3274.     HEX    71c7.fffe.cb2c.0001
  3275.     HEX    c62c.0001.604f.fff9
  3276.     HEX    3087.fff9.1900.0019
  3277.     HEX    1900.0019.197e.0019
  3278.     HEX    1981.0019.1e8e.0019
  3279.     HEX    0ccc.0019.3068.0019
  3280.     HEX    c864.0019.c864.0019
  3281.     HEX    c8c8.fc19.c99f.8219
  3282.     HEX    c981.9919.c9ff.9919
  3283.     HEX    c8fd.821f.c801.840e
  3284.     HEX    c801.8200.c801.91ce
  3285.     HEX    c801.9939.c801.9f32
  3286.     HEX    c801.d724.c800.e308
  3287.     HEX    c800.0304.cfff.e322
  3288.     HEX    c000.1331.c000.1339
  3289.     HEX    ffff.e3ef.7fff.c1c6
  3290. *
  3291.     HEX    71c7.fffe.fbef.ffff
  3292.     HEX    ffef.ffff.7fcf.ffff
  3293.     HEX    3fff.ffff.1fff.ffff
  3294.     HEX    1fff.ffff.1fff.ffff
  3295.     HEX    1fff.ffff.1fff.ffff
  3296.     HEX    0fff.ffff.3fff.ffff
  3297.     HEX    ffff.ffff.ffff.ffff
  3298.     HEX    ffff.ffff.ffff.ffff
  3299.     HEX    ffff.ffff.ffff.ffff
  3300.     HEX    ffff.ffff.ffff.ffff
  3301.     HEX    ffff.fff8.ffff.ffff
  3302.     HEX    ffff.ffff.ffff.ffff
  3303.     HEX    ffff.fffe.ffff.fffc
  3304.     HEX    ffff.fffc.ffff.fffe
  3305.     HEX    ffff.f3ff.ffff.f3ff
  3306.     HEX    ffff.e3ef.7fff.c1c6
  3307.     ENDR
  3308. *
  3309.     RSRC    ICN#,130,32
  3310.     HEX    71c7.fffe.cb2c.0001
  3311.     HEX    c62c.0001.604f.fff9
  3312.     HEX    3087.fff9.1900.0019
  3313.     HEX    1900.0019.1900.0019
  3314.     HEX    1900.0019.1e00.0019
  3315.     HEX    0c00.0019.3000.0019
  3316.     HEX    c800.0019.c800.0019
  3317.     HEX    c800.0019.c800.0019
  3318.     HEX    c800.0019.c800.0019
  3319.     HEX    c800.001f.c800.000f
  3320.     HEX    c800.0000.c800.01ce
  3321.     HEX    c800.0339.c800.0332
  3322.     HEX    c800.0324.c800.0308
  3323.     HEX    c800.0304.cfff.e322
  3324.     HEX    c000.1331.c000.1339
  3325.     HEX    ffff.e3cf.7fff.c1c6
  3326. *
  3327.     HEX    71c7.fffe.fbef.ffff
  3328.     HEX    ffef.ffff.7fff.ffff
  3329.     HEX    3fff.ffff.1fff.ffff
  3330.     HEX    1fff.ffff.1fff.ffff
  3331.     HEX    1fff.ffff.1fff.ffff
  3332.     HEX    0fff.ffff.3fff.ffff
  3333.     HEX    7fff.ffff.ffff.ffff
  3334.     HEX    ffff.ffff.ffff.ffff
  3335.     HEX    ffff.ffff.ffff.ffff
  3336.     HEX    ffff.ffff.ffff.ffff
  3337.     HEX    ffff.fffe.ffff.ffff
  3338.     HEX    ffff.ffff.ffff.ffff
  3339.     HEX    ffff.fffe.ffff.fffc
  3340.     HEX    ffff.fffc.ffff.fffe
  3341.     HEX    ffff.ffff.ffff.f3ff
  3342.     HEX    ffff.e3ef.7fff.c1c6
  3343.     ENDR
  3344. *
  3345.     RSRC    ICN#,131,32
  3346.     HEX    71c7.fffe.cb2c.0001
  3347.     HEX    c62c.0001.604f.fff9
  3348.     HEX    3087.fff9.1900.0019
  3349.     HEX    1900.0019.1900.0019
  3350.     HEX    1909.1899.1e09.2499
  3351.     HEX    0c09.2499.0009.1899
  3352.     HEX    7000.0019.c800.0019
  3353.     HEX    c989.2319.ca49.2499
  3354.     HEX    ca49.2499.c989.2319
  3355.     HEX    c800.001f.c800.000f
  3356.     HEX    c988.c000.ca49.21ce
  3357.     HEX    ca49.2339.c988.c332
  3358.     HEX    c800.0324.c800.0308
  3359.     HEX    c800.0304.cfff.f322
  3360.     HEX    c000.0b31.c000.0b39
  3361.     HEX    ffff.f3cf.7fff.e1c6
  3362. *
  3363.     HEX    71c7.fffe.fbef.ffff
  3364.     HEX    ffef.ffff.7fff.ffff
  3365.     HEX    3fff.ffff.1fff.ffff
  3366.     HEX    1fff.ffff.1fff.ffff
  3367.     HEX    1fff.ffff.1fff.ffff
  3368.     HEX    0fff.ffff.0fff.ffff
  3369.     HEX    7fff.ffff.ffff.ffff
  3370.     HEX    ffff.ffff.ffff.ffff
  3371.     HEX    ffff.ffff.ffff.ffff
  3372.     HEX    ffff.ffff.ffff.ffff
  3373.     HEX    ffff.fffe.ffff.ffff
  3374.     HEX    ffff.ffff.ffff.ffff
  3375.     HEX    ffff.fffe.ffff.fffc
  3376.     HEX    ffff.fffc.ffff.fffe
  3377.     HEX    ffff.ffff.ffff.ffff
  3378.     HEX    ffff.f7ff.7fff.e7ce
  3379.     ENDR
  3380. *
  3381.     RSRC    ICN#,132,32
  3382.     HEX    71c7.fffe.cb2c.0001
  3383.     HEX    c62c.0001.604f.fff9
  3384.     HEX    3087.fff9.1900.0019
  3385.     HEX    197f.0019.1900.0019
  3386.     HEX    190f.f019.1e00.0019
  3387.     HEX    0c0f.f019.0000.0019
  3388.     HEX    7001.fc19.c800.0019
  3389.     HEX    c87f.fc19.c800.0019
  3390.     HEX    c80f.8019.c800.0019
  3391.     HEX    c87f.fe19.c800.001f
  3392.     HEX    c80f.f000.c800.01ce
  3393.     HEX    c803.c339.c800.0332
  3394.     HEX    c8ff.c324.c800.0308
  3395.     HEX    c800.0304.cfff.e332
  3396.     HEX    c000.1339.c000.133d
  3397.     HEX    ffff.f3cf.7fff.e1c6
  3398. *
  3399.     HEX    638f.fffe.f7cf.ffff
  3400.     HEX    ffcf.ffff.7fff.ffff
  3401.     HEX    3fff.ffff.1fff.ffff
  3402.     HEX    1fff.ffff.1fff.ffff
  3403.     HEX    1fff.ffff.1fff.ffff
  3404.     HEX    1fff.ffff.7fff.ffff
  3405.     HEX    ffff.ffff.ffff.ffff
  3406.     HEX    ffff.ffff.ffff.ffff
  3407.     HEX    ffff.ffff.ffff.ffff
  3408.     HEX    ffff.ffff.ffff.ffff
  3409.     HEX    ffff.fffe.ffff.fffe
  3410.     HEX    ffff.fffe.ffff.fffe
  3411.     HEX    ffff.fffe.ffff.fffc
  3412.     HEX    ffff.fff8.ffff.fffc
  3413.     HEX    ffff.fffe.ffff.f3ff
  3414.     HEX    ffff.f3ee.7fff.f1c6
  3415.     ENDR
  3416. *
  3417.     RSRC    WIND,256
  3418.     DATA    /40,/2,/326,/498
  3419.     DATA    /8
  3420.     DATA    #1,#0
  3421.     DATA    #0,#0
  3422.     DATA    0
  3423.     STR    "yerk.com"
  3424.     ENDR
  3425. *
  3426.     RSRC    BNDL,128
  3427.     ASC    'YERK'
  3428.     DATA    /0
  3429.     DATA    /2-1
  3430.     ASC    'ICN#'
  3431.     DATA    /5-1
  3432.     DATA    /0,/128,/1,/129,/2,/130
  3433.     DATA    /3,/131,/4,/132
  3434.     ASC    'FREF'
  3435.     DATA    /5-1
  3436.     DATA    /0,/128,/1,/129,/2,/130
  3437.     DATA    /3,/131,/4,/132
  3438.     ENDR
  3439. *
  3440.     RSRC    SIZE,0
  3441.     DATA    /$5800
  3442.     DATA    1022976
  3443.     DATA    393216
  3444.     ENDR
  3445. *
  3446.     RSRC    SIZE,-1
  3447.     DATA    /$5800
  3448.     DATA    393216
  3449.     DATA    393216
  3450.     ENDR
  3451. *
  3452.     RSRC    vers,1
  3453.     DATA    $03308000
  3454.     DATA    /0000
  3455.     STR    "3.3.0"
  3456.     STR    "3.3.0 Yerkes Observatory"
  3457.     ENDR
  3458. *
  3459.     END
  3460.